#!/bin/sh
#| -*- C -*-
exec racket "$0" > `echo "$0" | sed 's/rktc$/c/'` "$0"
|#

#lang scribble/text

@(require "rktc-utils.rkt")

@header{foreign.rktc}

#include "schpriv.h"
#include "schmach.h"
#include "schrktio.h"

#ifndef DONT_USE_FOREIGN

#include <errno.h>

@@@IFDEF{MZ_USE_FFIPOLL}{
# define MZ_USE_FFIPOLL_COND 1
}{
# define MZ_USE_FFIPOLL_COND 0
}

@@IFNDEF{SIZEOF_BOOL}{
# define SIZEOF_BOOL 0
}
@@IF{SIZEOF_BOOL != 0}{
# include <stdbool.h>
}

@@@IFNDEF{WINDOWS_DYNAMIC_LOAD}{
# include <dlfcn.h>
}{
# include <windows.h>
}

@@@IF{!defined(WINDOWS_DYNAMIC_LOAD) || defined(__MINGW32__)}{
   typedef   signed char Tsint8;
   typedef unsigned char Tuint8;

# if SIZEOF_SHORT == 2
   typedef   signed short Tsint16;
   typedef unsigned short Tuint16;
# elif SIZEOF_INT == 2
   typedef   signed int Tsint16;
   typedef unsigned int Tuint16;
# else
#  error "configuration error, please contact PLT (int16)"
# endif

# if SIZEOF_INT == 4
   typedef   signed int Tsint32;
   typedef unsigned int Tuint32;
# elif SIZEOF_LONG == 4
   typedef   signed long Tsint32;
   typedef unsigned long Tuint32;
# else
#  error "configuration error, please contact PLT (int32)"
# endif

# if SIZEOF_LONG == 8
   typedef   signed long Tsint64;
   typedef unsigned long Tuint64;
# elif SIZEOF_LONG_LONG == 8
   typedef   signed long long Tsint64;
   typedef unsigned long long Tuint64;
# else
#  error "configuration error, please contact PLT (int64)"
# endif

}{

# ifndef __CYGWIN32__
#  include <wtypes.h>
   typedef          _int8  Tsint8;
   typedef unsigned _int8  Tuint8;
   typedef          _int16 Tsint16;
   typedef unsigned _int16 Tuint16;
   typedef          _int32 Tsint32;
   typedef unsigned _int32 Tuint32;
   typedef          _int64 Tsint64;
   typedef unsigned _int64 Tuint64;
# endif

}

#include "ffi.h"

typedef void *(*Scheme_Malloc_Proc)(size_t);
static Scheme_Malloc_Proc mode_to_allocator(const char *who, Scheme_Object *mode);

@defsymbols[nonatomic atomic stubborn uncollectable eternal
            interior atomic-interior raw tagged fail-ok]

#ifndef MZ_PRECISE_GC
# define XFORM_OK_PLUS +
# define GC_CAN_IGNORE /* empty */
#endif

#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))

/* same as the macro in file.c */
#define TO_PATH(x) (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x))

static void save_errno_values(int kind);

/* This make hides pointerness from cdefstruct so that it
   doesn't generate a mark/fixup action: */
#define NON_GCBALE_PTR(t) t*

static void overflow_error(const char *who, const char *op, intptr_t a, intptr_t b)
{
  scheme_contract_error(who, "arithmetic overflow",
                        "operation", 0, op,
                        "first argument", 1, scheme_make_integer(a),
                        "first argument", 1, scheme_make_integer(b),
                        NULL);
}

static intptr_t mult_check_overflow(const char *who, intptr_t a, intptr_t b)
{
  Scheme_Object *c;
  c = scheme_bin_mult(scheme_make_integer(a), scheme_make_integer(b));
  if (!SCHEME_INTP(c))
    overflow_error(who, "multiply", a, b);
  return SCHEME_INT_VAL(c);
}

static intptr_t add_check_overflow(const char *who, intptr_t a, intptr_t b)
{
  Scheme_Object *c;
  c = scheme_bin_plus(scheme_make_integer(a), scheme_make_integer(b));
  if (!SCHEME_INTP(c))
    overflow_error(who, "add", a, b);
  return SCHEME_INT_VAL(c);
}

/*****************************************************************************/
/* Library objects */

@cdefstruct[ffi-lib []
  [handle    "NON_GCBALE_PTR(rktio_dll_t)"]
  [name      "Scheme_Object*"]
  [is_global "int"]
  [refcount "int"]]

THREAD_LOCAL_DECL(static Scheme_Hash_Table *opened_libs);

/* (ffi-lib filename no-error? global?) -> ffi-lib */
@cdefine[ffi-lib 1 3]{
  char *name;
  Scheme_Object *path, *hashname;
  rktio_dll_t *handle;
  int as_global = 0;
  ffi_lib_struct *lib;
  if (!(SCHEME_PATH_STRINGP(argv[0]) || SCHEME_FALSEP(argv[0])))
    scheme_wrong_contract(MYNAME, "(or/c string? #f)", 0, argc, argv);
  as_global = ((argc > 2) && SCHEME_TRUEP(argv[2]));
  /* leave the filename as given, the system will look for it */
  /* (`#f' means open the executable) */
  path = SCHEME_FALSEP(argv[0]) ? NULL : TO_PATH(argv[0]);
  name = (path==NULL) ? NULL : SCHEME_PATH_VAL(path);
  hashname = (Scheme_Object*)((name==NULL) ? "" : name);
  lib = (ffi_lib_struct*)scheme_hash_get(opened_libs, hashname);
  if (!lib) {
    handle = rktio_dll_open(scheme_rktio, name, as_global);
    if (!handle) {
      char *msg;
      msg = rktio_dll_get_error(scheme_rktio);
      if (argc > 1 && SCHEME_TRUEP(argv[1])) {
        if (msg) free(msg);
        return scheme_false;
      } else {
        if (msg) {
          msg = scheme_strdup_and_free(msg);
          scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                           MYNAME": couldn't open %V (%s)", argv[0], msg);
        } else
          scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                           MYNAME": couldn't open %V (%R)", argv[0]);
      }
    }
    @cmake["lib" ffi-lib "handle" "argv[0]" "!name" "1"]
    scheme_hash_set(opened_libs, hashname, (Scheme_Object*)lib);
    /* no dlclose finalizer - since the hash table always keeps a reference */
    /* maybe add some explicit unload at some point */
  } else
    lib->refcount++;
  return (Scheme_Object*)lib;
}

/* (ffi-lib-name ffi-lib) -> string */
@cdefine[ffi-lib-name 1]{
  if (!SCHEME_FFILIBP(argv[0]))
    scheme_wrong_contract(MYNAME, "ffi-lib?", 0, argc, argv);
  return ((ffi_lib_struct*)argv[0])->name;
}

/* (ffi-lib-unload ffi-lib) -> (void) */
@cdefine[ffi-lib-unload 1]{
  ffi_lib_struct *lib;

  if (!SCHEME_FFILIBP(argv[0]))
    scheme_wrong_contract(MYNAME, "ffi-lib?", 0, argc, argv);

  lib = (ffi_lib_struct *)argv[0];
  if (!lib->handle)
    scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     MYNAME": couldn't close already-closed lib %V",
                     lib->name);

  --lib->refcount;
  if (lib->refcount)
    return scheme_void;
  
  if (rktio_dll_close(scheme_rktio, lib->handle)) {
    Scheme_Object *hashname;

    lib->handle = NULL;

    if (SCHEME_FALSEP(lib->name))
      hashname = (Scheme_Object *)"";
    else {
      hashname = TO_PATH(lib->name);
      hashname = (Scheme_Object *)SCHEME_PATH_VAL(hashname);
    }
    scheme_hash_set(opened_libs, hashname, NULL);
  } else {
    char *msg;
    msg = rktio_dll_get_error(scheme_rktio);
    if (msg) {
      msg = scheme_strdup_and_free(msg);
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                       MYNAME": couldn't close %V (%s)", lib->name, msg);
    } else
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                       MYNAME": couldn't close %V (%R)", lib->name);
  }

  return scheme_void;
}

/*****************************************************************************/
/* Pull pointers (mostly functions) out of ffi-lib objects */

@cdefstruct[ffi-obj []
  [obj  "NON_GCBALE_PTR(void)"]
  [name "char*"]
  [lib  "NON_GCBALE_PTR(ffi_lib_struct)"]]

/* (ffi-obj objname ffi-lib-or-libname) -> ffi-obj */
@cdefine[ffi-obj 2]{
  ffi_obj_struct *obj;
  void *dlobj;
  ffi_lib_struct *lib = NULL;
  char *dlname;
  if (SCHEME_FFILIBP(argv[1]))
    lib = (ffi_lib_struct*)argv[1];
  else if (SCHEME_PATH_STRINGP(argv[1]) || SCHEME_FALSEP(argv[1]))
    lib = (ffi_lib_struct*)(foreign_ffi_lib(1,&argv[1]));
  else
    scheme_wrong_contract(MYNAME, "ffi-lib?", 1, argc, argv);
  if (!SCHEME_BYTE_STRINGP(argv[0]))
    scheme_wrong_contract(MYNAME, "bytes?", 0, argc, argv);
  dlname = SCHEME_BYTE_STR_VAL(argv[0]);

  if (!lib->handle) {
    scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     MYNAME": couldn't get \"%s\" from already-closed %V",
                     dlname, lib->name);
  }

  dlobj = rktio_dll_find_object(scheme_rktio, lib->handle, dlname);
  if (!dlobj) {
    char *msg;
    msg = rktio_dll_get_error(scheme_rktio);
    if (msg) {
      msg = scheme_strdup_and_free(msg);
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                       MYNAME": couldn't get \"%s\" from %V (%s)",
                       dlname, lib->name, msg);
    } else
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                       MYNAME": couldn't get \"%s\" from %V (%R)",
                       dlname, lib->name);
  }

  if (dlobj) {
    @cmake["obj" ffi-obj "dlobj" "dlname" "lib"]
    return (Scheme_Object *)obj;
  } else
    return scheme_false;
}

/* (ffi-obj-lib ffi-obj) -> ffi-lib */
@cdefine[ffi-obj-lib 1 #:kind immed]{
  if (!SCHEME_FFIOBJP(argv[0]))
    scheme_wrong_contract(MYNAME, "ffi-obj?", 0, argc, argv);
  return (Scheme_Object*)(((ffi_obj_struct*)argv[0])->lib);
}

/* (ffi-obj-name ffi-obj) -> string */
@cdefine[ffi-obj-name 1 #:kind immed]{
  if (!SCHEME_FFIOBJP(argv[0]))
    scheme_wrong_contract(MYNAME, "ffi-obj?", 0, argc, argv);
  return scheme_make_byte_string(((ffi_obj_struct*)argv[0])->name);
}

/*****************************************************************************/
/* Type helpers */

/* These are not defined in Racket because:
 * - SCHEME_UINT_VAL is not really a simple accessor like other SCHEME_X_VALs
 * - scheme_make_integer_from_unsigned behaves the same as the signed version
 */
#define SCHEME_UINT_VAL(obj) ((unsigned)(SCHEME_INT_VAL(obj)))
#define scheme_make_integer_from_unsigned(i) \
  ((Scheme_Object *)((((uintptr_t)i) << 1) | 0x1))

@@@IFNDEF{SIXTY_FOUR_BIT_INTEGERS}{

/* longs and ints are really the same */
#define scheme_get_realint_val(x,y) \
  scheme_get_int_val(x,(intptr_t*)(y))
#define scheme_get_unsigned_realint_val(x,y) \
  scheme_get_unsigned_int_val(x,(uintptr_t*)(y))
#define scheme_make_realinteger_value \
  scheme_make_integer_value
#define scheme_make_realinteger_value_from_unsigned \
  scheme_make_integer_value_from_unsigned

}{

/* These will make sense in Racket when longs are longer than ints (needed
 * for libffi's int32 types).  There is no need to deal with bignums because
 * racket's fixnums are longs. */
XFORM_NONGCING int scheme_get_realint_val(Scheme_Object *o, int *v)
{
  if (SCHEME_INTP(o)) {
    uintptr_t lv = SCHEME_INT_VAL(o);
    int i = (int)lv;
    if (i != lv)
      return 0;
    *v = i;
    return 1;
  } else return 0;
}
XFORM_NONGCING int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v)
{
  if (SCHEME_INTP(o)) {
    uintptr_t lv = SCHEME_INT_VAL(o);
    unsigned int i = (unsigned int)lv;
    if (i != lv)
      return 0;
    *v = i;
    return 1;
  } else return 0;
}
#define scheme_make_realinteger_value(ri) \
  scheme_make_integer((intptr_t)(ri))
#define scheme_make_realinteger_value_from_unsigned(ri) \
  scheme_make_integer((uintptr_t)(ri))

}

XFORM_NONGCING MZ_INLINE static int get_byte_val(Scheme_Object *o, Tsint8 *_v)
{
  if (SCHEME_INTP(o)) {
    intptr_t v = SCHEME_INT_VAL(o);
    if ((v >= -128) && (v <= 127)) {
      *_v = v;
      return 1;
    }
  }
  return 0;
}

XFORM_NONGCING MZ_INLINE static int get_ubyte_val(Scheme_Object *o, Tuint8 *_v)
{
  if (SCHEME_INTP(o)) {
    intptr_t v = SCHEME_INT_VAL(o);
    if ((v >= 0) && (v <= 255)) {
      *_v = v;
      return 1;
    }
  }
  return 0;
}

XFORM_NONGCING MZ_INLINE static int get_short_val(Scheme_Object *o, Tsint16 *_v)
{
  if (SCHEME_INTP(o)) {
    intptr_t v = SCHEME_INT_VAL(o);
    if ((v >= -32768) && (v <= 32767)) {
      *_v = v;
      return 1;
    }
  }
  return 0;
}

XFORM_NONGCING MZ_INLINE static int get_ushort_val(Scheme_Object *o, Tuint16 *_v)
{
  if (SCHEME_INTP(o)) {
    intptr_t v = SCHEME_INT_VAL(o);
    if ((v >= 0) && (v <= 65536)) {
      *_v = v;
      return 1;
    }
  }
  return 0;
}

/* This is related to the section of scheme.h that defines mzlonglong. */
#ifndef INT64_AS_LONG_LONG
#ifdef  NO_LONG_LONG_TYPE
#ifndef SIXTY_FOUR_BIT_INTEGERS
#error foreign requires a 64-bit integer type type.
#endif
#endif
#endif

#define SCHEME_FALSEP_OR_CHAR_STRINGP(o) (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o))

XFORM_NONGCING static mzchar *ucs4_string_or_null_to_ucs4_pointer(Scheme_Object *ucs)
{
  if (SCHEME_FALSEP(ucs)) return NULL;
  return SCHEME_CHAR_STR_VAL(ucs);
}

static unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
{
  intptr_t ulen;
  unsigned short *res;
  res = scheme_ucs4_to_utf16
          (SCHEME_CHAR_STR_VAL(ucs), 0, SCHEME_CHAR_STRLEN_VAL(ucs),
           NULL, -1, &ulen, 1);
  res[ulen] = 0;
  return res;
}

static unsigned short *ucs4_string_or_null_to_utf16_pointer(Scheme_Object *ucs)
{
  if (SCHEME_FALSEP(ucs)) return NULL;
  return ucs4_string_to_utf16_pointer(ucs);
}

static Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
{
  intptr_t ulen, end;
  mzchar *res;
  if (!utf) return scheme_false;
  for (end=0; utf[end] != 0; end++) { /**/ }
  res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 1);
  res[ulen] = 0;
  return scheme_make_sized_char_string(res, ulen, 0);
}

/*****************************************************************************/
/* Types */

@DEFINE{MZ_TYPE_CAST(t, e) (t)(e)}
@DEFINE{MZ_NO_TYPE_CAST(t, e) (e)}

@(begin
;; Types are defined with the `defctype' function.  This looks like:
;;   (defctype 'type-name
;;     'prop1 val1
;;     'prop2 val2
;;     ...)
;; The current properties are:
;;   stype: scheme binding for this type
;;   cname: like stype but used for C identifiers
;;   ftype: type name used by libffi (as ffi_type_X) (defaults to cname)
;;   ctype: C type, or #f if none (defaults to ftype, with proper massaging)
;;   macro: if specified as "X", use "SCHEME_XP" and "SCHEME_X_VAL" as the
;;          defaults for the next two properties
;;   pred:  name of predicate macro
;;    (or a function of the value and an ForeignAny obj pointer name, which
;;     produces an expression that tests the value and sets the ForeignAny obj
;;     accordingly.)
;;   s->c:  name of value extraction macro
;;    (or #f which means that the predicate already sets the value, or a
;;     function with the same arguments as above)
;;   c->s:  name of value construction macro/function
;;    (or a function of the value that generates the expression)
;;   offset: if specified as "X", use "SCHEME_X_OFFSET" to extract an offset
;;    value for s->c, otherwise leave 0 as the offset

(define types null)

(require (for-syntax racket/base))

(define (get-prop type prop)
  (cadr (assq prop (cdr (assq type types)))))

(define type-counter
  (let ([c 0])
    (lambda ([flag #f])
      (case flag
        [(#f)   (set! c (add1 c)) c]
        [(last) (begin0 (add1 c) (set! c #f))]
        [else (error "internal error")]))))

(define (describe-type stype cname ftype ctype pred s->c c->s offset)
  @list{
    #define FOREIGN_@cname (@(type-counter))
    /* Type Name:   @|stype|@(and (not (equal? cname stype)) @list{ (@cname)})
     * LibFfi type: ffi_type_@ftype
     * C type:      @(or ctype "-none-")
     * Predicate:   @(cond [(not pred) "-none-"]
                           [(procedure? pred) (pred "<Scheme>" "aux")]
                           [else @list{@|pred|(<Scheme>)}])
     * Racket->C:   @(cond [(not s->c)
                            (if pred "-none- (set by the predicate)" "-none-")]
                           [(procedure? s->c) (s->c "<Scheme>" "aux")]
                           [else @list{@|s->c|(<Scheme>)}])
     * S->C offset: @(or offset 0)
     * C->Racket:   @(cond [(not c->s) "-none-"]
                           [(procedure? c->s) (c->s "<C>")]
                           [else @list{@|c->s|(<C>)}])
     */})

(define (make-ctype type args)
  (define (prop p . default)
    (let loop ([args args])
      (cond [(null? args) (and (pair? default) (car default))]
            [(eq? p (car args))
             (if (and (pair? (cadr args)) (eq? (caadr args) 'from))
               (get-prop (cadadr args) p)
               (cadr args))]
            [else (loop (cddr args))])))
  (let* ([stype (symbol->string type)]
         [cname (racket-id->c-name stype)]
         [ftype (prop 'ftype cname)]
         [ctype (prop 'ctype
                      (regexp-replace
                       #rx"^sint"
                       (regexp-replace #rx"^(u?int(?:[0-9]+))$" ftype "\\1_t")
                       "int"))]
         [ftype (regexp-replace #rx"^(int|char|long)" ftype "s\\1")]
         [macro (prop 'macro)]
         [pred  (prop 'pred (and macro @list{SCHEME_@|macro|P}))]
         [s->c  (prop 's->c (and macro @list{SCHEME_@|macro|_VAL}))]
         [c->s  (prop 'c->s)]
         [offset (prop 'offset #f)]
         [unwrap? (prop 'unwrap? #f)]
         [cast (prop 'cast 'MZ_TYPE_CAST)])
    (output (describe-type stype cname ftype ctype pred s->c c->s offset))
    `(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype)
      (macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset) 
      (unwrap? ,unwrap?) (cast ,cast))))

(define (defctype name . args)
  (set! types (append types (list (make-ctype name args)))))

(define-syntax (map-types stx)
  (syntax-case stx ()
    [(_ body ...)
     (let ()
       (define (id sym) (datum->syntax stx sym stx))
       (define-values (exprs semi?)
          (syntax-case stx ()
            [(_ #:semicolons? s? body ...) (values #'(body ...) #'s?)]
            [(_ body ...) (values #'(body ...) #'#t)]))
       (with-syntax ([(body ...) exprs]
                     [semi? semi?]
                     [stype (id 'stype)]
                     [cname (id 'cname)]
                     [ctype (id 'ctype)]
                     [ftype (id 'ftype)]
                     [macro (id 'macro)]
                     [pred  (id 'pred)]
                     [s->c  (id 's->c)]
                     [c->s  (id 'c->s)]
                     [offset (id 'offset)]
                     [ptr?  (id 'ptr?)]
                     [unwrap? (id 'unwrap?)]
                     [cast  (id 'cast)])
         #'(maplines #:semicolons? 'semi?
                     (lambda (t)
                       (define data (cdr t))
                      (define (get sym) (cadr (assq sym data)))
                       (let* ([stype (get 'stype)]
                              [cname (get 'cname)]
                              [ftype (get 'ftype)]
                              [ctype (get 'ctype)]
                              [macro (get 'macro)]
                              [pred  (get 'pred)]
                              [s->c  (get 's->c)]
                              [c->s  (get 'c->s)]
                              [offset (get 'offset)]
                              [ptr? (or (equal? "pointer" ftype)
                                        (equal? "gcpointer" ftype))]
                              [unwrap? (get 'unwrap?)]
                              [cast (get 'cast)])
                         body ...))
                     types)))]))

(define (defctype* name/+ftype ctype pred s->c c->s . more)
  (let ([name (if (pair? name/+ftype) (car name/+ftype) name/+ftype)]
        [ftype (and (pair? name/+ftype) (cadr name/+ftype))])
    (apply defctype name
      `(ctype ,ctype
        ,@(if ftype `(ftype ,ftype) `())
        pred ,(if (string? pred) @list{SCHEME_@|pred|P}     pred)
        s->c ,(if (string? s->c) @list{SCHEME_@|s->c|_VAL}  s->c)
        c->s ,(if (string? c->s) @list{scheme_make_@|c->s|} c->s)
        ,@more))))

)

/***********************************************************************
 * The following are the only primitive types.
 * The tricky part is figuring out what width-ed types correspond to
 * what internal types.  Matthew says:
 *   Racket expects to be compiled such that sizeof(int) == 4,
 *   sizeof(intptr_t) == sizeof(void*), sizeof(short) >= 2,
 *   sizeof(char) == 1, sizeof(float) == 4, and sizeof(double) == 8.
 *   So, on a 64-bit OS, Racket expects only `long' and `intptr_t' to change.
 **********************************************************************/

/* returns #<void> when used as output type, not for input types. */
@(defctype 'void
   'ctype #f 'pred #f 's->c #f 'c->s (lambda (x) "scheme_void"))

@(defctype* 'int8 "Tsint8"
   (lambda (x aux) @list{get_byte_val(@x,&@aux)}) #f
   "integer")

@(defctype* 'uint8 "Tuint8"
   (lambda (x aux) @list{get_ubyte_val(@x,&@aux)}) #f
   "integer")

@(defctype* 'int16 "Tsint16"
   (lambda (x aux) @list{get_short_val(@x,&@aux)}) #f
   "integer")

@(defctype* 'uint16 "Tuint16"
   (lambda (x aux) @list{get_ushort_val(@x,&@aux)}) #f
   "integer")

/* Treats integers properly: */
@(defctype* 'int32  "Tsint32"
   (lambda (x aux) @list{scheme_get_realint_val(@x,&@aux)}) #f
  "realinteger_value")

/* Treats integers properly: */
@(defctype* 'uint32 "Tuint32"
   (lambda (x aux) @list{scheme_get_unsigned_realint_val(@x,&@aux)}) #f
   "realinteger_value_from_unsigned")

@; mzlonglong is always assumed to be 64 bits, or the above will throw an error
@(defctype* 'int64  "Tsint64"
   (lambda (x aux) @list{scheme_get_long_long_val(@x,&@aux)}) #f
   "integer_value_from_long_long")

@(defctype* 'uint64 "Tuint64"
   (lambda (x aux) @list{scheme_get_unsigned_long_long_val(@x,&@aux)}) #f
   "integer_value_from_unsigned_long_long")

/* This is like int32, but always assumes fixnum: */
@(defctype* '(fixint "int32")   "Tsint32"  "INT" "INT"  "integer")

/* This is like uint32, but always assumes fixnum: */
@(defctype* '(ufixint "uint32") "Tuint32" "INT" "UINT" "integer_from_unsigned")

@@@IFNDEF{SIXTY_FOUR_BIT_LONGS}{
#define ffi_type_smzlong ffi_type_sint32
#define ffi_type_umzlong ffi_type_uint32
}{
#define ffi_type_smzlong ffi_type_sint64
#define ffi_type_umzlong ffi_type_uint64
}

@@@IFNDEF{SIXTY_FOUR_BIT_INTEGERS}{
#define ffi_type_smzintptr ffi_type_sint32
#define ffi_type_umzintptr ffi_type_uint32
}{
#define ffi_type_smzintptr ffi_type_sint64
#define ffi_type_umzintptr ffi_type_uint64
}

/* This is what mzscheme defines as intptr, assuming fixnums: */
@(defctype* '(fixnum "smzintptr")
   "intptr_t"          "INT" "INT"  "integer")

/* This is what mzscheme defines as uintptr, assuming fixnums: */
@(defctype* '(ufixnum "umzintptr")
   "uintptr_t" "INT" "UINT" "integer_from_unsigned")

@(defctype* 'float  "float"        "FLOAT"  "FLOAT"        "double")

@(defctype* 'double "double"       "FLOAT"  "FLOAT"        "double")

@@@IFDEF{_MSC_VER}{
  struct struct_align_slongdouble {
    char c;
    long_double x;
  };
  const ffi_type ffi_type_slongdouble = {		
    sizeof(long_double),
    offsetof(struct struct_align_slongdouble, x),
    FFI_TYPE_STRUCT, NULL					
  };
}{
  @DEFINE{ffi_type_slongdouble ffi_type_longdouble}
}
@@@IFDEF{MZ_LONG_DOUBLE}{
  @DEFINE{SCHEME_MAYBE_LONG_DBL_VAL(x) SCHEME_LONG_DBL_VAL(x)}
}{
  @DEFINE{SCHEME_MAYBE_LONG_DBL_VAL(x) unsupported_long_double_val()}
  static mz_long_double unsupported_long_double_val() { 
    scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "_longdouble: " NOT_SUPPORTED_STR);    
    return 0.0;
  }
}
@@@IFDEF{MZ_LONG_DOUBLE}{
  @DEFINE{scheme_make_maybe_long_double(x) scheme_make_long_double(x)}
 }{
  @DEFINE{scheme_make_maybe_long_double(x) unsupported_make_long_double()}
  static Scheme_Object *unsupported_make_long_double() {
    scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "_longdouble: " NOT_SUPPORTED_STR);    
    return NULL;
  }
}

@(defctype* '(longdouble "longdouble") "mz_long_double" "LONG_DBL"  "MAYBE_LONG_DBL" "maybe_long_double"
   'cast 'MZ_NO_TYPE_CAST)


/* A double that will coerce numbers to doubles: */
@(defctype* '(double* "double") "double"
   ;; use a list to avoid automatic "SCHEME_..._VAL" wrapping
   "REAL" '("scheme_real_to_double") "double")

/* Booleans -- implemented as an int which is 1 or 0: */
@(defctype 'bool
   'ftype "int"
   'pred (lambda (x aux) "1")
   's->c "SCHEME_TRUEP"
   'c->s (lambda (x) @list{(@|x|?scheme_true:scheme_false)}))

@@@IF{SIZEOF_BOOL == 0}{
typedef signed char stdbool;
# define ffi_type_stdbool ffi_type_sint8
}{
typedef bool stdbool;
@@@IF{SIZEOF_BOOL == 1}{
# define ffi_type_stdbool ffi_type_sint8
}{
@@@IF{SIZEOF_BOOL == 2}{
# define ffi_type_stdbool ffi_type_sint16
}{
@@@IF{SIZEOF_BOOL == 4}{
# define ffi_type_stdbool ffi_type_sint32
}{
@@@IF{SIZEOF_BOOL == 8}{
# define ffi_type_stdbool ffi_type_sint64
}{
/* ??? Pick something */
# define ffi_type_stdbool ffi_type_int
}}}}}

/* Booleans -- implemented as an int which is 1 or 0: */
@(defctype 'stdbool
   'ftype "stdbool"
   'pred (lambda (x aux) "1")
   's->c "SCHEME_TRUEP"
   'c->s (lambda (x) @list{(@|x|?scheme_true:scheme_false)}))

/* Strings -- no copying is done (when possible).
 * #f is not NULL only for byte-strings, for other strings it is
 * meaningless to use NULL. */

@(defctype 'string/ucs-4
   'ftype "gcpointer"
   'ctype "mzchar*"
   'pred  "SCHEME_FALSEP_OR_CHAR_STRINGP"
   's->c  "ucs4_string_or_null_to_ucs4_pointer"
   'c->s  "scheme_make_char_string_without_copying")

@(defctype 'string/utf-16
   'ftype "gcpointer"
   'ctype "unsigned short*"
   'pred  "SCHEME_FALSEP_OR_CHAR_STRINGP"
   's->c  "ucs4_string_or_null_to_utf16_pointer"
   'c->s  "utf16_pointer_to_ucs4_string")

/* Byte strings -- not copying C strings, #f is NULL.
 * (note: these are not like char* which is just a pointer) */

@(defctype 'bytes
   'ftype "gcpointer"
   'ctype "char*"
   'pred  (lambda (x aux)
            @list{SCHEME_FALSEP(@x)||SCHEME_BYTE_STRINGP(@x)})
   's->c  (lambda (x aux)
            @list{SCHEME_FALSEP(@x)?NULL:SCHEME_BYTE_STR_VAL(@x)})
   'c->s  (lambda (x)
            @list{(@|x|==NULL)?scheme_false:@;
                  scheme_make_byte_string_without_copying(@x)}))

@(defctype 'path
   'ftype "gcpointer"
   'ctype "char*"
   'pred  (lambda (x aux)
            @list{SCHEME_FALSEP(@x)||SCHEME_PATH_STRINGP(@x)})
   's->c  (lambda (x aux)
            @list{SCHEME_FALSEP(@x)?NULL:SCHEME_PATH_VAL(TO_PATH(@x))})
   'c->s  (lambda (x)
            @list{(@|x|==NULL)?scheme_false:@;
                  scheme_make_path_without_copying(@x)}))

@(defctype 'symbol
   'ftype "pointer"
   'ctype "char*"
   'pred  "SCHEME_SYMBOLP"
   's->c  "SCHEME_SYM_VAL"
   'c->s  "scheme_intern_symbol")

/* This is for any C pointer: #f is NULL, cpointer values as well as
 * ffi-obj and string values pass their pointer.  When used as a return
 * value, either a cpointer object or #f is returned. */
@(defctype 'pointer
   'ctype "void*"
   'unwrap? #t
   'macro "FFIANYPTR"
   'offset "FFIANYPTR"
   'c->s  "scheme_make_foreign_external_cpointer")

@(defctype 'gcpointer
   'ftype "gcpointer"
   'unwrap? #t
   'ctype "void*"
   'macro "FFIANYPTR"
   'offset "FFIANYPTR"
   'c->s  "scheme_make_foreign_cpointer")

@; This is probably not needed
@; /* Used for ffi-callback objects: */
@; @(defctype 'callback
@;    'ftype "pointer"
@;    'ctype "void*"
@;    'macro "FFICALLBACK"
@;    's->c  (lambda (x aux) @list{((ffi_callback_struct*)(@x))->callback})
@;    'c->s  (lambda (x) x))
@;
/* This is used for passing and Scheme_Object* value as is.  Useful for
 * functions that know about Scheme_Object*s, like Racket's. */
@(defctype 'scheme
   'ftype "gcpointer"
   'ctype "Scheme_Object*"
   'pred (lambda (x aux) "1")
   's->c (lambda (x aux) x)
   'c->s (lambda (x) x))

/* Special type, not actually used for anything except to mark values
 * that are treated like pointers but not referenced.  Used for
 * creating function types. */
@(defctype 'fpointer 'ftype "pointer" 'ctype "void*" 'unwrap? #t)

typedef union _ForeignAny {
  @(map-types (when ctype @list{@ctype x_@cname}))
} ForeignAny;

/* This is a tag that is used to identify user-made struct types. */
@; last makes sure this is the last one value that gets used
#define FOREIGN_struct (@(type-counter))
#define FOREIGN_array (@(type-counter))
#define FOREIGN_union (@(type-counter 'last))

XFORM_NONGCING static int is_gcable_pointer(Scheme_Object *o) {
  if (SCHEME_FFIOBJP(o)) return 0;
  return (!SCHEME_CPTRP(o) 
          || !(SCHEME_CPTR_FLAGS(o) & 0x1));
}

/*****************************************************************************/
/* Type objects */

/* This struct is used for both user types and primitive types (including
 * struct types).  If it is a user type then basetype will be another ctype,
 * otherwise,
 * - if it's a primitive type, then basetype will be a symbol naming that type
 * - if it's a struct or union, then basetype will be the list of ctypes that
 *   made this struct, prefixed with a symbol if the allocation mode is not 'atomic
 * scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
 * integer (a label value) for non-struct type.  (Note that the
 * integer is not really needed, since it is possible to identify the
 * type by the basetype field.)
 */
@cdefstruct[ctype [#:tag "scheme_ctype_type"]
  [basetype    "Scheme_Object*"]
  [scheme_to_c "Scheme_Object*"]
  [c_to_scheme "Scheme_Object*"]]

static ffi_type ffi_type_gcpointer;

#define CTYPE_BASETYPE(x)  (((ctype_struct*)(x))->basetype)
#define CTYPE_USERP(x)     (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
#define CTYPE_PRIMP(x)     (!CTYPE_USERP(x))
#define CTYPE_PRIMTYPE(x)  ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
#define CTYPE_PRIMLABEL(x) ((intptr_t)(((ctype_struct*)(x))->c_to_scheme))
#define CTYPE_USER_S2C(x)  (((ctype_struct*)(x))->scheme_to_c)
#define CTYPE_USER_C2S(x)  (((ctype_struct*)(x))->c_to_scheme)

#define CTYPE_ARG_PRIMTYPE(x) ((CTYPE_PRIMLABEL(x) == FOREIGN_array) ? &ffi_type_pointer : CTYPE_PRIMTYPE(x))

/* Returns #f for primitive types. */
@cdefine[ctype-basetype 1 #:kind immed]{
  Scheme_Object *r;
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  r = CTYPE_BASETYPE(argv[0]);
  if (SCHEME_PAIRP(r) && SCHEME_SYMBOLP(SCHEME_CAR(r))) {
    /* strip allocation mode for struct/union */
    r = SCHEME_CDR(r);
  }
  return r;
}

@cdefine[ctype-scheme->c 1 #:kind immed]{
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  return (CTYPE_PRIMP(argv[0])) ? scheme_false :
           ((ctype_struct*)(argv[0]))->scheme_to_c;
}

@cdefine[ctype-c->scheme 1 #:kind immed]{
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  return (CTYPE_PRIMP(argv[0])) ? scheme_false :
           ((ctype_struct*)(argv[0]))->c_to_scheme;
}

/* Returns a primitive type, or NULL if not a type */
XFORM_NONGCING static Scheme_Object *get_ctype_base(Scheme_Object *type)
{
  if (!SCHEME_CTYPEP(type)) return NULL;
  while (CTYPE_USERP(type)) { type = CTYPE_BASETYPE(type); }
  return type;
}

/* Returns the size, 0 for void, -1 if no such type */
XFORM_NONGCING static intptr_t ctype_sizeof(Scheme_Object *type)
{
  type = get_ctype_base(type);
  if (type == NULL) return -1;
  switch (CTYPE_PRIMLABEL(type)) {
  @(map-types @list{case FOREIGN_@|cname|: @;
                      return @(if ctype @list{sizeof(@ctype)} "0")})
  /* for structs and arrays */
  default: return CTYPE_PRIMTYPE(type)->size;
  }
}

/* (make-ctype basetype scheme->c c->scheme) -> ctype */
/* The scheme->c can throw type errors to check for valid arguments */
/* a #f means no conversion function, if both are #f -- then just return the */
/* basetype. */
@cdefine[make-ctype 3]{
  ctype_struct *type;
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  else if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
    scheme_wrong_contract(MYNAME, "(or/c procedure? #f)", 1, argc, argv);
  else if (!(SCHEME_FALSEP(argv[2]) || SCHEME_PROCP(argv[2])))
    scheme_wrong_contract(MYNAME, "(or/c procedure? #f)", 2, argc, argv);
  else if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(argv[2]))
    return argv[0];
  else {
    @cmake["type" ctype "argv[0]" "argv[1]" "argv[2]"]
    return (Scheme_Object*)type;
  }
  @hush
}

/* see below */
static void free_libffi_type(void *ignored, void *p)
{
  free(((ffi_type*)p)->elements);
  free(p);
}

static void free_libffi_type_two_layers(void *ignored, void *p)
{
  int i;
  
  for (i = 0; ((ffi_type*)p)->elements[i]; i++) {
    free(((ffi_type*)p)->elements[i]);
  }
  free_libffi_type(ignored, p);
}

/*****************************************************************************/
/* ABI spec */

@defsymbols[default stdcall sysv]

static ffi_abi sym_to_abi(const char *who, Scheme_Object *sym)
{
  if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym))
    return FFI_DEFAULT_ABI;
  else if (SAME_OBJ(sym, sysv_sym)) {
#if defined(WINDOWS_DYNAMIC_LOAD) && !defined(_WIN64)
    return FFI_SYSV;
#else
    scheme_signal_error("%s: ABI not implemented: %V", who, sym);
#endif
  } else if (SAME_OBJ(sym, stdcall_sym)) {
#if defined(WINDOWS_DYNAMIC_LOAD) && !defined(_WIN64)
    return FFI_STDCALL;
#else
    scheme_signal_error("%s: ABI not implemented: %V", who, sym);
#endif
  } else {
    scheme_signal_error("%s: unknown ABI: %V", who, sym);
  }
  return 0; /* hush the compiler */
}

/* helper macro */
#define GET_ABI(name,n) \
  ((argc > (n)) ? sym_to_abi((name),argv[n]) : FFI_DEFAULT_ABI)

/*****************************************************************************/
/* cstruct types */

static void wrong_void(const char *who, Scheme_Object *list_element, int specifically_void,
                       int which, int argc, Scheme_Object **argv)
{
  intptr_t len;
  char *s;

  if (argc > 1)
    s = scheme_make_arg_lines_string("  ", which, argc, argv, &len);
  else
    s = NULL;

  if (list_element) {
    scheme_contract_error(who,
                          (specifically_void
                           ? "C type within list is based on _void"
                           : "C type within list has a zero size"),
                          "C type", 1, list_element,
                          "list", 1, argv[which],
                          s ? "other arguments" : NULL, 0, s,
                          NULL);
  } else
    scheme_contract_error(who,
                          (specifically_void
                           ? "given C type is based on _void"
                           : "given C type has a zero size"),
                          "given C type", 1, argv[which],
                          s ? "other arguments" : NULL, 0, s,
                          NULL);
}

/* (make-cstruct-type types [abi alignment malloc-mode]) -> ctype */
/* This creates a new primitive type that is a struct.  This type can be used
 * with cpointer objects, except that the contents is used rather than the
 * pointer value.  Marshaling to lists or whatever should be done in Racket. */
@cdefine[make-cstruct-type 1 4]{
  Scheme_Object *p, *base;
  /* since ffi_type objects can be used in callbacks, they are allocated using
   * malloc so they don't move, and they are freed when the Scheme object is
   * GCed. */
  GC_CAN_IGNORE ffi_type **elements, *libffi_type, **dummy;
  ctype_struct *type;
  ffi_cif cif;
  int i, nargs, with_alignment;
  ffi_abi abi;
  Scheme_Object *fields = argv[0];
  nargs = scheme_proper_list_length(fields);
  if (nargs <= 0) scheme_wrong_contract(MYNAME, "(non-empty-listof ctype?)", 0, argc, argv);
  abi = GET_ABI(MYNAME,1);
  if (argc > 2) {
    if (!SCHEME_FALSEP(argv[2])) {
      if (!SAME_OBJ(argv[2], scheme_make_integer(1))
          && !SAME_OBJ(argv[2], scheme_make_integer(2))
          && !SAME_OBJ(argv[2], scheme_make_integer(4))
          && !SAME_OBJ(argv[2], scheme_make_integer(8))
          && !SAME_OBJ(argv[2], scheme_make_integer(16)))
        scheme_wrong_contract(MYNAME, "(or/c 1 2 4 8 16 #f)", 2, argc, argv);
      with_alignment = SCHEME_INT_VAL(argv[2]);
    } else
      with_alignment = 0;
    if (argc > 3) {
      if (!SAME_OBJ(argv[3], atomic_sym)) {
        (void)mode_to_allocator(MYNAME, argv[3]);
        fields = scheme_make_pair(argv[3], fields);
      }
    }
  } else
    with_alignment = 0;

    /* allocate the type elements */
  elements = malloc((nargs+1) * sizeof(ffi_type*));
  elements[nargs] = NULL;
  for (i=0, p=argv[0]; i<nargs; i++, p=SCHEME_CDR(p)) {
    if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
      scheme_wrong_contract(MYNAME, "(non-empty-listof ctype?)", 0, argc, argv);
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
      wrong_void(MYNAME, SCHEME_CAR(p), 1, 0, argc, argv);
    elements[i] = CTYPE_PRIMTYPE(base);
    if (with_alignment) {
      /* copy the type to set an alignment: */
      libffi_type = malloc(sizeof(ffi_type));
      memcpy(libffi_type, elements[i], sizeof(ffi_type));
      elements[i] = libffi_type;
      if (with_alignment < elements[i]->alignment)
        elements[i]->alignment = with_alignment;
    }
  }

  /* allocate the new libffi type object */
  libffi_type = malloc(sizeof(ffi_type));
  libffi_type->size      = 0;
  libffi_type->alignment = 0;
  libffi_type->type      = FFI_TYPE_STRUCT;
  libffi_type->elements  = elements;
  /* use ffi_prep_cif to set the size and alignment information */
  dummy = &libffi_type;
  if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK)
    scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
  @cmake["type" ctype "fields"
         "(Scheme_Object*)libffi_type"
         "(Scheme_Object*)FOREIGN_struct"]
  if (with_alignment)
    scheme_register_finalizer(type, free_libffi_type_two_layers, libffi_type, NULL, NULL);
  else
    scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
  return (Scheme_Object*)type;
}

/*****************************************************************************/
/* array types */

static void wrong_intptr(const char *who, int which, int argc, Scheme_Object **argv)
{
  if (!SCHEME_INTP(argv[which]) && !SCHEME_BIGNUMP(argv[which])) {
    scheme_wrong_contract(who, "exact-integer?", which, argc, argv);
  } else {
    intptr_t len;
    char *s;
    
    if (argc > 1)
      s = scheme_make_arg_lines_string("  ", which, argc, argv, &len);
    else
      s = NULL;

    scheme_contract_error(who,
                          "given integer does not fit into the _intptr type",
                          "given integer", 1, argv[which],
                          s ? "other arguments" : NULL, 0, s,
                          NULL);
  }
}

#if defined(__aarch64__)
# define SMALL_ARRAY_THRESHOLD 64
#else
# define SMALL_ARRAY_THRESHOLD 32
#endif

/* (make-array-type type len) -> ctype */
/* This creates a new primitive type that is an array. An array is the
 * same as a cpointer as an argument, but it behave differently within
 * a struct or for allocation. Marshaling to lists or whatever should 
 * be done in Racket. */
@cdefine[make-array-type 2 2]{
  Scheme_Object *base, *basetype;
  GC_CAN_IGNORE ffi_type *libffi_type, **elements;
  ctype_struct *type;
  intptr_t len, size;

  if (NULL == (base = get_ctype_base(argv[0])))
    scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  if (!scheme_get_int_val(argv[1], &len) || (len < 0)) {
    if ((SCHEME_INTP(argv[1]) && SCHEME_INT_VAL(argv[1]) > 0)
        || (SCHEME_BIGNUMP(argv[1]) && SCHEME_BIGPOS(argv[1])))
      wrong_intptr(MYNAME, 1, argc, argv);
    else
      scheme_wrong_contract(MYNAME, "exact-nonnegative-integer?", 1, argc, argv);
  }

  /* libffi doesn't seem to support array types, but we try to make
     libffi work anyway by making a structure type that is used when
     an array appears as a struct field. If the array size is 4 or
     less, or if the total size is SMALL_ARRAY_THRESHOLD bytes or
     less, then we make a full `elements' array, because the x86_64
     ABI always shifts to memory mode after 32 bytes and the AArch64
     ABI shifts after 64 bytes. */

  /* Allocate the new libffi type object, which is only provided to
     libffi as a type for a structure field.  When a FOREIGN_array
     type is used for a function argument or result, it is replaced
     with FOREIGN_pointer.  We put FFI_TYPE_STRUCT in
     libffi_type->type and make an elements array that contains
     a single instance of the element type... which seems to work
     ok so far.  */
  libffi_type = malloc(sizeof(ffi_type));
  size = mult_check_overflow(MYNAME, CTYPE_PRIMTYPE(base)->size, len);
  libffi_type->size      = size;
  libffi_type->alignment = CTYPE_PRIMTYPE(base)->alignment;
  libffi_type->type      = FFI_TYPE_STRUCT;

  if ((libffi_type->size <= SMALL_ARRAY_THRESHOLD) || (len <= 4)) {
    int i;
    elements = malloc((len + 1) * sizeof(ffi_type*));
    for (i = 0; i < len; i++) {
      elements[i] = CTYPE_PRIMTYPE(base);
    }
    elements[len] = NULL;
  } else {
    elements = malloc(2 * sizeof(ffi_type*));
    elements[0] = CTYPE_PRIMTYPE(base);
    elements[1] = NULL;
  }
  libffi_type->elements  = elements;

  basetype = scheme_make_vector(2, argv[0]);
  SCHEME_VEC_ELS(basetype)[1] = argv[1];

  @cmake["type" ctype "basetype"
         "(Scheme_Object*)libffi_type"
         "(Scheme_Object*)FOREIGN_array"]

  scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);

  return (Scheme_Object*)type;
}

/*****************************************************************************/
/* union types */

static int all_float_types(GC_CAN_IGNORE ffi_type *libffi_type);

/* (make-union-type type ...+) -> ctype */
/* This creates a new primitive type that is a union. All unions
 * behave like structs. Marshaling to lists or whatever should 
 * be done in Racket. */
@cdefine[make-union-type 1 -1]{
  Scheme_Object *base, *basetype;
  GC_CAN_IGNORE ffi_type *libffi_type, **elements = NULL;
  ctype_struct *type;
  int i, align = 1, a, sz = 0, count = 0, float_kinds = 0, float_kind;
  int some_non_floats = 0;

  /* libffi doesn't support union types, so we try to make a
     reasonable approximation. The calling convention of a union type
     mostly likely depends on of the maximum size of all alternatives
     and whether it's floating-point or not. Synthesize a struct that
     is big enough and composed of only floats if the union
     alternative are only floats or integers otherwise. This is not
     guaranteed to be right, but it has a chance at working. */

  /* find max required alignment and size: */
  for (i = 0; i < argc; i++) {
    if (NULL == (base = get_ctype_base(argv[i]))) {
      free(elements);
      scheme_wrong_contract(MYNAME, "ctype?", i, argc, argv);
    }
    a = CTYPE_PRIMTYPE(base)->alignment;
    if (a > align) align = a;
    a = CTYPE_PRIMTYPE(base)->size;
    if (sz < a) sz = a;

    float_kind = all_float_types(CTYPE_PRIMTYPE(base));
    if (i == 0) float_kinds = float_kind;
    if (!float_kind || (float_kind != float_kinds))
      some_non_floats = 1;
  }

  if (!sz)
    scheme_signal_error("empty union");
  
  /* round size up to alignment: */
  if ((sz % align) != 0) {
    sz += (align - (sz % align));
  }

  /* Synthesize element list */
  while (!elements) {
    if (count)
      elements = malloc((count+1) * sizeof(ffi_type*));
    count = 0;

    if (some_non_floats) {
      /* build a struct out of integers */
      int remain_sz = sz;
      while (remain_sz >= sizeof(intptr_t)) {
        if (elements)
          elements[count] = &ffi_type_smzintptr;
        remain_sz -= sizeof(intptr_t);
        count++;
      }
      while (remain_sz >= sizeof(int)) {
        if (elements)
          elements[count] = &ffi_type_sint32;
        remain_sz -= sizeof(int);
        count++;
      }
      while (remain_sz >= sizeof(short)) {
        if (elements)
          elements[count] = &ffi_type_sint16;
        remain_sz -= sizeof(short);
        count++;
      }
      while (remain_sz) {
        if (elements)
          elements[count] = &ffi_type_sint8;
        remain_sz -= 1;
        count++;
      }
      /* remain_sz should be 0 at this point */
    } else {
      /* build a struct out of doubles and floats */
      int remain_sz = sz;
      while (remain_sz >= sizeof(double)) {
        if (elements)
          elements[count] = &ffi_type_double;
        remain_sz -= sizeof(double);
        count++;
      }
      while (remain_sz >= sizeof(float)) {
        if (elements)
          elements[count] = &ffi_type_float;
        remain_sz -= sizeof(float);
        count++;
      }
      /* remain_sz should be 0 at this point */
    }
  }

  elements[count] = NULL;

  /* Allocate the new libffi type object. */
  libffi_type = malloc(sizeof(ffi_type));
  libffi_type->size      = sz;
  libffi_type->alignment = align;
  libffi_type->type      = FFI_TYPE_STRUCT;
  libffi_type->elements  = elements;

  basetype = scheme_box(scheme_build_list(argc, argv));

  @cmake["type" ctype "basetype"
         "(Scheme_Object*)libffi_type"
         "(Scheme_Object*)FOREIGN_union"]

  scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);

  return (Scheme_Object*)type;
}

static Scheme_Object *all_float_types_k(void)
{
  Scheme_Thread *p = scheme_current_thread;
  int r;
  r = all_float_types((ffi_type *)p->ku.k.i1);
  return scheme_make_integer(r);
}

#if defined(__arm__) || defined(__thumb__) || defined(__aarch64__)
/* Arm: uniform floats must be the same type */
# define FLOAT_KIND_DOUBLE 1
# define FLOAT_KIND_FLOAT  2
# define FLOAT_KIND_EXT    3
#else
/* Other: different kinds of floats are treated the same */
# define FLOAT_KIND_DOUBLE 1
# define FLOAT_KIND_FLOAT  1
# define FLOAT_KIND_EXT    1
#endif

static int all_float_types(GC_CAN_IGNORE ffi_type *libffi_type)
{
  {
# include "mzstkchk.h"
    {
      Scheme_Thread *p = scheme_current_thread;
      Scheme_Object *r;
      p->ku.k.i1 = (intptr_t)libffi_type;
      r = scheme_handle_stack_overflow(all_float_types_k);
      return SCHEME_INT_VAL(r);
    }
  }

  if (libffi_type == &ffi_type_double)
    return FLOAT_KIND_DOUBLE;
  if (libffi_type == &ffi_type_float)
    return FLOAT_KIND_FLOAT;
  if (libffi_type == &ffi_type_longdouble)
    return FLOAT_KIND_EXT;

  if (libffi_type->type == FFI_TYPE_STRUCT) {
    int i, kind = 0, k;
    for (i = 0; libffi_type->elements[i]; i++) {
      k = all_float_types(libffi_type->elements[i]);
      if (!k)
        return 0;
      if (!i)
        kind = k;
      else if (kind != k)
        return 0;
    }
    return kind;
  }

  return 0;
}

/*****************************************************************************/
/* Callback type */

@cdefstruct[ffi-callback []
  [callback "NON_GCBALE_PTR(void)"]
  [proc     "Scheme_Object*"]
  [itypes   "Scheme_Object*"]    ;; NULL for a curried callback
  [otype    "Scheme_Object*"]    ;;NULL for a curried callback */
  [sync     "Scheme_Object*"]]   /* pointer to another ffi-callback for a curried callback */

/* The sync field:
 *   NULL => non-atomic mode
 *   #t => atomic mode, no sync proc
 *   proc => non-atomic mode, sync proc
 *   (box proc) => atomic mode, sync proc
*/

/*****************************************************************************/
/* Pointer objects */
/* use cpointer (with a NULL tag when creating), #f for NULL */

#define SCHEME_FFIANYPTRP(x) \
  (SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(x) || \
   SCHEME_BYTE_STRINGP(x) || SCHEME_FFICALLBACKP(x))
#define SCHEME_FFIANYPTR_VAL(x) \
  (SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \
    (SCHEME_FALSEP(x) ? NULL : \
      (SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
       (SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
         (SCHEME_FFICALLBACKP(x) ? ((ffi_callback_struct *)x)->callback : \
          NULL)))))
#define SCHEME_FFIANYPTR_OFFSET(x) \
  (SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
#define SCHEME_FFIANYPTR_OFFSETVAL(x) \
  W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x))

#define SCHEME_CPOINTER_W_OFFSET_P(x) \
  (SCHEME_CPTRP(x) && SCHEME_CPTR_HAS_OFFSET(x))

#define scheme_make_foreign_cpointer(x) \
  ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))

#define scheme_make_foreign_offset_cpointer(x, delta) \
  ((delta == 0) ? scheme_make_foreign_cpointer(x) : scheme_make_offset_cptr(x,delta,NULL))

#define scheme_make_foreign_external_cpointer(x) \
  ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL))

#define scheme_make_foreign_offset_external_cpointer(x, delta) \
  ((delta == 0) ? scheme_make_foreign_external_cpointer(x) : scheme_make_offset_external_cptr(x,delta,NULL))

static int check_cpointer_property(Scheme_Object *v)
{
  if (SCHEME_CHAPERONE_STRUCTP(v)
      && scheme_struct_type_property_ref(scheme_cpointer_property, v))
    return 1;
  else
    return 0;
}

static Scheme_Object *unwrap_cpointer_property_slow(Scheme_Object *orig_v)
{
  Scheme_Object *v = orig_v, *val;
  int must = 0;

  while (1) {
    if (SCHEME_CHAPERONE_STRUCTP(v)) {
      val = scheme_struct_type_property_ref(scheme_cpointer_property, v);
      if (val) {
        if (SCHEME_INTP(val))
          v = scheme_struct_ref(v, SCHEME_INT_VAL(val));
        else if (SCHEME_PROCP(val)) {
          Scheme_Object *a[1];
          a[0] = v;
          v = _scheme_apply(val, 1, a);
        } else
          v = val;
        must = 1;
      } else 
        break;
    } else
      break;
  }

  if (must && !SCHEME_FFIANYPTRP(v)) {
    scheme_wrong_contract("prop:cpointer accessor", "cpointer?", 0, -1, &v);
    return NULL;
  }

  return v;
}

static Scheme_Object *unwrap_cpointer_property(Scheme_Object *v)
{
  if (SCHEME_FFIANYPTRP(v))
    return v;
  else
    return unwrap_cpointer_property_slow(v);
}

int scheme_is_cpointer(Scheme_Object *cp) {
  return (SCHEME_FFIANYPTRP(cp) || check_cpointer_property(cp));
}

@cdefine[cpointer? 1 #:kind immed]{
  return (scheme_is_cpointer(argv[0])
          ? scheme_true
          : scheme_false);
}

@cdefine[cpointer-tag 1 #:kind inline_noncm]{
  Scheme_Object *tag = NULL;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  if (SCHEME_CPTRP(cp)) tag = SCHEME_CPTR_TYPE(cp);
  return (tag == NULL) ? scheme_false : tag;
}

Scheme_Object *scheme_cpointer_tag(Scheme_Object *ptr)
{
  Scheme_Object *a[1];
  a[0] = ptr;
  return foreign_cpointer_tag(1, a);
}

@cdefine[set-cpointer-tag! 2 #:kind inline_noncm]{
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_CPTRP(cp))
    scheme_wrong_contract(MYNAME, "proper-cpointer?", 0, argc, argv);
  SCHEME_CPTR_TYPE(cp) = argv[1];
  return scheme_void;
}

void scheme_set_cpointer_tag(Scheme_Object *ptr, Scheme_Object *val)
{
  Scheme_Object *a[2];
  a[0] = ptr;
  a[1] = val;
  (void)foreign_set_cpointer_tag_bang(2, a);
}

@cdefine[cpointer-gcable? 1]{
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (SCHEME_CPTRP(cp)) {
    return ((SCHEME_CPTR_FLAGS(cp) & 0x1)
            ? scheme_false
            : scheme_true);
  } else if (SCHEME_FALSEP(cp)
             || SCHEME_FFIOBJP(cp)
             || SCHEME_FFICALLBACKP(cp))
    return scheme_false;
  else if (SCHEME_BYTE_STRINGP(cp))
    return scheme_true;
  else {
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
    return NULL;
  }
}

void *scheme_extract_pointer(Scheme_Object *v) {
  return SCHEME_FFIANYPTR_OFFSETVAL(v);
}

/*****************************************************************************/
/* Racket<-->C conversions */

/* On big endian machines we need to know whether we're pulling a value from an
 * argument location where it always takes a whole word or straight from a
 * memory location -- deal with it via a C2SCHEME macro wrapper that is used
 * for both the function definition and calls */
#ifdef SCHEME_BIG_ENDIAN
#define C2SCHEME(ap,typ,src,delta,argsloc,gcsrc) c_to_scheme(ap,typ,src,delta,argsloc,gcsrc)
#define REF_CTYPE(ctype) (((sizeof(ctype)<sizeof(intptr_t)) && args_loc) \
  ? ((ctype)(((intptr_t*)W_OFFSET(src,delta))[0])) \
  : (((ctype *)W_OFFSET(src,delta))[0]))
#else
#define C2SCHEME(ap,typ,src,delta,argsloc,gcsrc) c_to_scheme(ap,typ,src,delta,gcsrc)
#define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
#endif

static Scheme_Object *C2SCHEME(Scheme_Object *already_ptr, Scheme_Object *type, void *src,
                               intptr_t delta, int args_loc, int gcsrc)
{
  Scheme_Object *res;
  if (!SCHEME_CTYPEP(type))
    scheme_wrong_contract("C->Racket", "ctype?", 0, 1, &type);
  if (CTYPE_USERP(type)) {
    res = C2SCHEME(already_ptr, CTYPE_BASETYPE(type), src, delta, args_loc, gcsrc);
    if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
      return res;
    else
      return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
  } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
    if (already_ptr) return already_ptr;
    return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta));
  } else switch (CTYPE_PRIMLABEL(type)) {
    @(map-types
      @list{case FOREIGN_@|cname|: return @;
              @(if ctype
                 (let ([x (list "REF_CTYPE("ctype")")])
                   (if (procedure? c->s) (c->s x) (list c->s"("x")")))
                 "scheme_void")})
    case FOREIGN_struct:
    case FOREIGN_array:
    case FOREIGN_union:
      if (gcsrc)
        return scheme_make_foreign_offset_cpointer(src, delta);
      else
        return scheme_make_foreign_offset_external_cpointer(src, delta);
    default: scheme_signal_error("corrupt foreign type: %V", type);
  }
  @hush
}
#undef REF_CTYPE

static void *wrong_value(const char *who, const char *type, Scheme_Object *val)
{
  scheme_contract_error(who, 
                        "given value does not fit primitive C type", 
                        "C type", 0, type,
                        "given value", 1, val,
                        NULL);
  return NULL;
}

/* On big endian machines we need to know whether we're pulling a value from an
 * argument location where it always takes a whole word or straight from a
 * memory location -- deal with it as above, via a SCHEME2C macro wrapper that
 * is used for both the function definition and calls, but the actual code in
 * the function is different: in the relevant cases zero an int and offset the
 * ptr */

/* Usually writes the C object to dst and returns NULL.  When basetype_p is not
 * NULL, then any pointer value (any pointer or a struct or array) is returned, and the
 * basetype_p is set to the corresponding number tag.  If basetype_p is NULL,
 * then a struct or array value will be *copied* into dst. */
static void* SCHEME2C(const char *who,
                      Scheme_Object *type, void *dst, intptr_t delta,
                      Scheme_Object *val, GC_CAN_IGNORE intptr_t *basetype_p, GC_CAN_IGNORE intptr_t *_offset,
                      int ret_loc)
{
  /* redundant check:
     if (!SCHEME_CTYPEP(type))
       scheme_wrong_contract(who, "ctype?", 0, 1, &type); */
  while (CTYPE_USERP(type)) {
    GC_CAN_IGNORE Scheme_Object *f = CTYPE_USER_S2C(type);
    if (!SCHEME_FALSEP(f)) {
      if (SAME_TYPE(SCHEME_TYPE(f), scheme_native_closure_type))
        val = _scheme_apply_native(f, 1, (Scheme_Object**)(&val));
      else
        val = _scheme_apply(f, 1, (Scheme_Object**)(&val));
    }
    type = CTYPE_BASETYPE(type);
  }
  if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
    val = unwrap_cpointer_property(val);
    /* No need for the SET_CTYPE trick for pointers. */
    if (SCHEME_FFICALLBACKP(val))
      ((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback;
    else if (SCHEME_CPTRP(val))
      ((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val);
    else if (SCHEME_FFIOBJP(val))
      ((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj;
    else if (SCHEME_FALSEP(val))
      ((void**)W_OFFSET(dst,delta))[0] = NULL;
    else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
      return wrong_value(who, "_fpointer", val);
  } else switch (CTYPE_PRIMLABEL(type)) {
    @(map-types #:semicolons? #f
       (define (wrong-type obj type)
        @list{return wrong_value(who, "_@type", val);})
       @list{
         case FOREIGN_@|cname|:
           @(let* ([x (and ctype @list{(((@|ctype|*)W_OFFSET(dst,delta))[0])})]
                   [f (lambda (p)
                        (if (procedure? p) @p["val" x] @list{@|p|(val)}))])
              (cond
                [(not x)
                 @list{if (!ret_loc) @wrong-type["type" "void"];
                       break;
                      }]
                [(not s->c)
                 @list{
                       @@IFDEF{SCHEME_BIG_ENDIAN}{
                       if (sizeof(@ctype)<sizeof(intptr_t) && ret_loc) {
                         ((int*)W_OFFSET(dst,delta))[0] = 0;
                         delta += (sizeof(intptr_t)-sizeof(@ctype));
                       }}
                       @@IFDEF{FFI_CALLBACK_NEED_INT_CLEAR}{
                         if (sizeof(@ctype)<sizeof(intptr_t) && ret_loc) {
                           ((int*)W_OFFSET(dst,delta))[0] = 0;
                         }
                       }
                       if (!(@(if ptr? "ret_loc" (pred "val" x)))) @;
                         @wrong-type["val" stype];
                       @(if ptr? "break" "return NULL");}]
                [else
                 @list{
                   @@IFDEF{SCHEME_BIG_ENDIAN}{
                   if (sizeof(@ctype)<sizeof(intptr_t) && ret_loc) {
                     ((int*)W_OFFSET(dst,delta))[0] = 0;
                     delta += (sizeof(intptr_t)-sizeof(@ctype));
                   }}
                   @@IFDEF{FFI_CALLBACK_NEED_INT_CLEAR}{
                     if (sizeof(@ctype)<sizeof(intptr_t) && ret_loc) {
                       ((int*)W_OFFSET(dst,delta))[0] = 0;
                     }
                   }
                   @(if unwrap?
                       @list{val = unwrap_cpointer_property(val);}
                       null)
                   if (@f[pred]) {
                     @ctype tmp@";"@and[offset]{ intptr_t toff@";"}
                     tmp = @cast(@ctype, @f[s->c]);
                     @and[offset @list{toff = SCHEME_@|offset|_OFFSET(val);@"\n"}]@;
                     @(if ptr?
                          @list{if (basetype_p == NULL || @;
                                    @(if offset
                                       @list{(tmp == NULL && toff == 0)}
                                       @list{tmp == NULL}) || @;
                                    @(if (equal? ftype "pointer")
                                         @list{!is_gcable_pointer(val)}
                                         @list{0})) {
                                  @and[offset @list{if (_offset) *_offset = 0;@"\n"}]@;
                                  @x = @(if offset
                                         @list{(@ctype)W_OFFSET(tmp, toff);}
                                         "tmp");
                                  return NULL;
                                } else {
                                  *basetype_p = FOREIGN_@cname;
                                  @and[offset @list{
                                      toff = SCHEME_@|offset|_OFFSET(val);
                                      if (_offset) *_offset = toff;@;
                                      @"\n"  }]@;
                                  return @(if offset
                                            @list{_offset ? tmp : @;
                                                    (@ctype)W_OFFSET(tmp, toff)}
                                            "tmp");
                                }}
                          @list{@x = tmp@";" return NULL@";"})
                   } else {
                     @wrong-type["val" stype];
                     @hush
                   }}]))})
    case FOREIGN_struct:
    case FOREIGN_array:
    case FOREIGN_union:
      val = unwrap_cpointer_property(val);
      if (!SCHEME_FFIANYPTRP(val)) {
        switch (CTYPE_PRIMLABEL(type)) {
        case FOREIGN_struct:
          return wrong_value(who, "(_struct ....)", val);
          break;
        case FOREIGN_array:
          return wrong_value(who, "(_array ....)", val);
          break;
        default:
        case FOREIGN_union:
          return wrong_value(who, "(_union ....)", val);
          break;
        }
      }
      {
        void* p = SCHEME_FFIANYPTR_VAL(val);
        intptr_t poff = SCHEME_FFIANYPTR_OFFSET(val);
        if (basetype_p == NULL) {
          if (p == NULL && poff == 0)
            scheme_signal_error("FFI pointer value was NULL");
          memcpy(W_OFFSET(dst, delta), W_OFFSET(p, poff),
                 CTYPE_PRIMTYPE(type)->size);
          return NULL;
        } else {
          *basetype_p = CTYPE_PRIMLABEL(type);
          if (_offset && is_gcable_pointer(val)) {
            *_offset = poff;
            return p;
          } else {
            return W_OFFSET(p, poff);
          }
        }
      }
    default: scheme_signal_error("corrupt foreign type: %V", type);
  }
  return NULL; /* hush the compiler */
}
#undef SET_CTYPE

/*****************************************************************************/
/* C type information */

/* (ctype-sizeof type) -> int, returns 0 for void, error if not a C type */
@cdefine[ctype-sizeof 1 #:kind immed]{
  intptr_t size;
  size = ctype_sizeof(argv[0]);
  if (size >= 0) return scheme_make_integer(size);
  else scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  return NULL; /* hush the compiler */
}

/* (ctype-alignof type) -> int, returns 0 for void, error if not a C type */
@cdefine[ctype-alignof 1 #:kind immed]{
  Scheme_Object *type;
  type = get_ctype_base(argv[0]);
  if (type == NULL) scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  else return scheme_make_integer(CTYPE_PRIMTYPE(type)->alignment);
  return NULL; /* hush the compiler */
}

/* (compiler-sizeof symbols) -> int, where symbols name some C type.
 * The symbols are in 'int 'char 'void 'short 'long '*, order does not matter,
 * when a single symbol is used, a list is not needed.
 * (This is about actual C types, not C type objects.) */
@cdefine[compiler-sizeof 1 #:kind immed]{
  int res=0;
  int basetype = 0; /* 1=int, 2=char, 3=void, 4=float, 5=double, 6=wchar_t */
  int intsize = 0;  /* "short" => decrement, "long" => increment */
  int stars = 0;    /* number of "*"s */
  int must_list = 0;
  Scheme_Object *l = argv[0], *p;
  while (!SAME_OBJ(l, scheme_null)) {
    if (SCHEME_PAIRP(l)) { p = SCHEME_CAR(l); l = SCHEME_CDR(l); must_list = 1;}
    else if (must_list) { p = scheme_false; l = scheme_null; }
    else { p = l; l = scheme_null; }
    if (!SCHEME_SYMBOLP(p)) {
      scheme_wrong_contract(MYNAME, "(or/c symbol? (listof symbol?))", 0, argc, argv);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"int")) {
      if (basetype==0) basetype=1;
      else scheme_signal_error(MYNAME": extraneous type: %V", p);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"char")) {
      if (basetype==0) basetype=2;
      else scheme_signal_error(MYNAME": extraneous type: %V", p);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"wchar")) {
      if (basetype==0) basetype=6;
      else scheme_signal_error(MYNAME": extraneous type: %V", p);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"void")) {
      if (basetype==0) basetype=3;
      else scheme_signal_error(MYNAME": extraneous type: %V", p);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"float")) {
      if (basetype==0) basetype=4;
      else scheme_signal_error(MYNAME": extraneous type: %V", p);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"double")) {
      if (basetype==0 || basetype==4) basetype=5;
      else scheme_signal_error(MYNAME": extraneous type: %V", p);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"short")) {
      if (intsize>0)
        scheme_signal_error(MYNAME": cannot use both 'short and 'long");
      else intsize--;
    } else if (!strcmp(SCHEME_SYM_VAL(p),"long")) {
      if (intsize<0)
        scheme_signal_error(MYNAME": cannot use both 'short and 'long");
      else intsize++;
    } else if (!strcmp(SCHEME_SYM_VAL(p),"*")) {
      stars++;
    } else {
      scheme_wrong_contract(MYNAME, "(or/c ctype-symbol? (listof ctype-symbol?))", 0, argc, argv);
    }
  }
  if (stars > 1)
    scheme_signal_error(MYNAME": cannot handle more than one '*");
  if (intsize < -1)
    scheme_signal_error(MYNAME": cannot handle more than one 'short");
  if (intsize > 2)
    scheme_signal_error(MYNAME": cannot handle more than two 'long");
  if (basetype == 0) basetype = 1; /* int is the default type */
  /* don't assume anything, so it can be used to verify compiler assumptions */
  /* (only forbid stuff that the compiler doesn't allow) */
  @DEFINE{RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *))}
  switch (basetype) {
  case 1: /* int */
    switch (intsize) {
    case 0:  RETSIZE(int); break;
    case 1:  RETSIZE(long int); break;
    @@@IFDEF{INT64_AS_LONG_LONG}{
    case 2:  RETSIZE(_int64); break; /* MSVC doesn't allow long long */
    }{
    case 2:  RETSIZE(long long int); break;
    }
    case -1: RETSIZE(short int); break;
    }
    break;
  case 2: /* char */
    if (intsize==0) RETSIZE(char);
    else scheme_signal_error(MYNAME": cannot qualify 'char");
    break;
  case 3: /* void */
    if (intsize==0 && stars>0) RETSIZE(int); /* avoid sizeof(void) */
    else if (stars==0)
      scheme_signal_error(MYNAME": cannot use 'void without a '*");
    else scheme_signal_error(MYNAME": cannot qualify 'void");
    break;
  case 4: /* float */
    if (intsize==0) RETSIZE(float);
    else scheme_signal_error(MYNAME": bad qualifiers for 'float");
    break;
  case 5: /* double */
    if (intsize==0) RETSIZE(double);
    else if (intsize==1) RETSIZE(mz_long_double);
    else scheme_signal_error(MYNAME": bad qualifiers for 'double");
    break;
  case 6: /* wchar_t */
    if (intsize==0) RETSIZE(wchar_t);
    else scheme_signal_error(MYNAME": cannot qualify 'wchar");
    break;
  default:
    scheme_signal_error(MYNAME": internal error (unexpected type %d)",
                        basetype);
  }
  @UNDEF{RETSIZE}
  return scheme_make_integer(res);
}

/*****************************************************************************/
/* Pointer type user functions */

static Scheme_Malloc_Proc mode_to_allocator(const char *who, Scheme_Object *mode)
{
  Scheme_Malloc_Proc mf;

  if (SAME_OBJ(mode, nonatomic_sym))          mf = scheme_malloc;
  else if (SAME_OBJ(mode, atomic_sym))        mf = scheme_malloc_atomic;
  else if (SAME_OBJ(mode, stubborn_sym))      mf = scheme_malloc_stubborn;
  else if (SAME_OBJ(mode, eternal_sym))       mf = scheme_malloc_eternal;
  else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
  else if (SAME_OBJ(mode, interior_sym))      mf = scheme_malloc_allow_interior;
  else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
  else if (SAME_OBJ(mode, raw_sym))           mf = malloc;
  else if (SAME_OBJ(mode, tagged_sym))        mf = scheme_malloc_tagged;
  else {
    scheme_signal_error("%s: bad allocation mode: %V", who, mode);
    return NULL; /* hush the compiler */
  }

  return mf;
}

static Scheme_Malloc_Proc ctype_allocator(Scheme_Object *type)
{
  Scheme_Object *mode;

  mode = CTYPE_BASETYPE(type);
  if (!SCHEME_PAIRP(mode))
    mode = atomic_sym;
  else {
    mode = SCHEME_CAR(mode);
    if (!SCHEME_SYMBOLP(mode))
      mode = atomic_sym;
  }

  return mode_to_allocator("_struct", mode);
}

/* (malloc num type cpointer mode) -> pointer */
/* The arguments for this function are:
 * - num: bytes to allocate, or the number of instances of type when given,
 * - type: malloc the size of this type (or num instances of it),
 * - cpointer: a source pointer to copy contents from,
 * - mode: a symbol for different allocation functions to use - one of
 *   'nonatomic, 'atomic, 'stubborn, 'uncollectable, 'eternal, 'tagged,
 *   or 'raw (the last one is for using the real malloc)
 * - if an additional 'fail-ok flag is given, then scheme_malloc_fail_ok is
 *   used with the chosen malloc function
 * The arguments can be specified in any order at all since they are all
 * different types, the only requirement is for a size, either a number of
 * bytes or a type.  If no mode is specified, then scheme_malloc will be used
 * when the type is any pointer, otherwise scheme_malloc_atomic is used. */
@cdefine[malloc 1 5]{
  int i, failok=0;
  intptr_t size=0, num=-1;
  void *from = NULL, *res = NULL;
  intptr_t foff = 0;
  Scheme_Object *mode = NULL, *a, *base = NULL;
  Scheme_Malloc_Proc mf;
  for (i=0; i<argc; i++) {
    a = unwrap_cpointer_property(argv[i]);
    if (SCHEME_INTP(a)) {
      if (num != -1)
        scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
      num = SCHEME_INT_VAL(a);
      if (num < 0)
        scheme_wrong_contract(MYNAME, "(and/c exact-nonnegative-integer? fixnum?)", 0, argc, argv);
    } else if (SCHEME_CTYPEP(a)) {
      if (size != 0)
        scheme_signal_error(MYNAME": specifying a second type: %V", a);
      if (NULL == (base = get_ctype_base(a)))
        scheme_wrong_contract(MYNAME, "ctype?", i, argc, argv);
      size = ctype_sizeof(a);
      if (size <= 0)
        wrong_void(MYNAME, NULL, 0, i, argc, argv);
    } else if (SAME_OBJ(a, fail_ok_sym)) {
      failok = 1;
    } else if (SCHEME_SYMBOLP(a)) {
      if (mode != NULL)
        scheme_signal_error(MYNAME": specifying a second mode symbol: %V", a);
      mode = a;
    } else if (SCHEME_FFIANYPTRP(a) && !SCHEME_FALSEP(a)) {
      if (from != NULL)
        scheme_signal_error(MYNAME": specifying a second source pointer: %V",
                            a);
      from = SCHEME_FFIANYPTR_VAL(a);
      foff = SCHEME_FFIANYPTR_OFFSET(a);
    } else {
      scheme_wrong_contract(MYNAME, 
                            "(or/c (and/c exact-nonnegative-integer? fixnum?)\n"
                            "      ctype?\n"
                            "      (or/c 'nonatomic 'stubborn 'uncollectable\n"
                            "             'eternal 'interior 'atomic-interior\n"
                            "             'tagged 'raw)\n"
                            "      'fail-on\n"
                            "      (and/c cpointer? (not/c #f)))", 
                            i, argc, argv);
    }
  }
  if (!num) return scheme_false;
  if ((num == -1) && (size == 0)) scheme_signal_error(MYNAME": no size given");
  size = mult_check_overflow(MYNAME, ((size==0) ? 1 : size), ((num==-1) ? 1 : num));
  if (mode == NULL)
    mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
      ? scheme_malloc : scheme_malloc_atomic;
  else
    mf = mode_to_allocator(MYNAME, mode);
  res = scheme_malloc_fail_ok(mf,size);
  if (failok && (res == NULL)) scheme_signal_error("malloc: out of memory");

  /* We might want to use foff as the object base address if from is NULL,
   * therefore set a src point to use in memcpy to clarify this */
  {
    void *src = NULL;
    if (from != NULL)
      src = W_OFFSET(from, foff);
    else if (foff != 0)
      src = (void *)foff;
    if (src != NULL && res != NULL)
      memcpy(res, src, size);
  }
  
  if (SAME_OBJ(mode, raw_sym))
    return scheme_make_foreign_external_cpointer(res);
  else
    return scheme_make_foreign_cpointer(res);
}

#define NON_NULL_CPOINTER "(and/c cpointer? (not/c (lambda (p) (pointer-equal? p #f))))"

/* (end-stubborn-change ptr) */
@cdefine[end-stubborn-change 1]{
  void *ptr;
  intptr_t poff;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(cp);
  poff = SCHEME_FFIANYPTR_OFFSET(cp);
  if ((ptr == NULL) && (poff == 0))
    scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
  scheme_end_stubborn_change(W_OFFSET(ptr, poff));
  return scheme_void;
}

/* (free ptr) */
/* This is useful for raw-malloced objects, including objects from C libraries
 * that the library is mallocing itself. */
@cdefine[free 1]{
  void *ptr;
  intptr_t poff;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(cp);
  poff = SCHEME_FFIANYPTR_OFFSET(cp);
  if ((ptr == NULL) && (poff == 0))
    scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
  free(W_OFFSET(ptr, poff));
  return scheme_void;
}

/* (malloc-immobile-cell v) */
@cdefine[malloc-immobile-cell 1 #:kind immed]{
  void *p;
  p = scheme_malloc_immobile_box(argv[0]);
  return scheme_make_foreign_external_cpointer(p); /* <- beware: macro duplicates `p' */
}

/* (free-immobile-cell b) */
@cdefine[free-immobile-cell 1]{
  void *ptr;
  intptr_t poff;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(cp);
  poff = SCHEME_FFIANYPTR_OFFSET(cp);
  if ((ptr == NULL) && (poff == 0))
    scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
  scheme_free_immobile_box((void **)W_OFFSET(ptr, poff));
  return scheme_void;
}

/* (ptr-add cptr offset-k [type])
 *   Adds an offset to a pointer, returning an offset_cpointer value
 * (ptr-add! cptr offset-k [type])
 *   Modifies an existing offset_cpointer value by adjusting its offset field,
 *   returns void
 */
static Scheme_Object *do_ptr_add(const char *who, int is_bang,
                                 int argc, Scheme_Object **argv)
{
  intptr_t noff;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (is_bang) {
    if (!SCHEME_CPOINTER_W_OFFSET_P(cp))
      scheme_wrong_contract(who, "offset-ptr?", 0, argc, argv);
  } else {
    if (!SCHEME_FFIANYPTRP(cp))
      scheme_wrong_contract(who, "cpointer?", 0, argc, argv);
  }
  if (!scheme_get_int_val(argv[1], &noff))
    wrong_intptr(who, 1, argc, argv);
  if (argc > 2) {
    if (SCHEME_CTYPEP(argv[2])) {
      intptr_t size;
      size = ctype_sizeof(argv[2]);
      if (size < 0)
        scheme_wrong_contract(who, "ctype?", 2, argc, argv);
      if (size <= 0) wrong_void(who, NULL, 0, 2, argc, argv);
      noff = mult_check_overflow(who, noff, size);
    } else
      scheme_wrong_contract(who, "ctype?", 2, argc, argv);
  }
  if (is_bang) {
    intptr_t delta;
    delta = add_check_overflow(who, ((Scheme_Offset_Cptr*)(cp))->offset, noff);
    ((Scheme_Offset_Cptr*)(cp))->offset = delta;
    return scheme_void;
  } else {
    intptr_t delta;
    delta = add_check_overflow(who, SCHEME_FFIANYPTR_OFFSET(cp), noff);
    if (SCHEME_CPTRP(cp) && (SCHEME_CPTR_FLAGS(cp) & 0x1))
      return scheme_make_offset_external_cptr
        (SCHEME_FFIANYPTR_VAL(cp),
         delta,
         (SCHEME_CPTRP(cp)) ? SCHEME_CPTR_TYPE(cp) : NULL);
    else
      return scheme_make_offset_cptr
        (SCHEME_FFIANYPTR_VAL(cp),
         delta,
         (SCHEME_CPTRP(cp)) ? SCHEME_CPTR_TYPE(cp) : NULL);
  }
}

/* (ptr-add cptr offset-k [type]) */
@cdefine[ptr-add 2 3]{return do_ptr_add(MYNAME, 0, argc, argv);}
/* (ptr-add! cptr offset-k [type]) */
@cdefine[ptr-add! 2 3]{return do_ptr_add(MYNAME, 1, argc, argv);}

/* (offset-ptr? x) */
/* Returns #t if the argument is a cpointer with an offset */
@cdefine[offset-ptr? 1 1]{
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  return (SCHEME_CPOINTER_W_OFFSET_P(cp)) ? scheme_true : scheme_false;
}

/* (ptr-offset ptr) */
/* Returns the offset of a cpointer (0 if it's not an offset pointer) */
@cdefine[ptr-offset 1 1]{
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(cp));
}

/* (set-ptr-offset! ptr offset [type]) */
/* Sets the offset of an offset-cpointer (possibly multiplied by the size of
 * the given ctype) */
@cdefine[set-ptr-offset! 2 3]{
  intptr_t noff;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_CPOINTER_W_OFFSET_P(cp))
    scheme_wrong_contract(MYNAME, "offset-ptr?", 0, argc, argv);
  if (!scheme_get_int_val(argv[1], &noff))
    wrong_intptr(MYNAME, 1, argc, argv);
  if (argc > 2) {
    if (SCHEME_CTYPEP(argv[2])) {
      intptr_t size;
      if (NULL == get_ctype_base(argv[2]))
        scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv);
      size = ctype_sizeof(argv[2]);
      if (size <= 0)
        wrong_void(MYNAME, NULL, 0, 2, argc, argv);
      noff = mult_check_overflow(MYNAME, noff, size);
    } else
      scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv);
  }
  ((Scheme_Offset_Cptr*)(cp))->offset = noff;
  return scheme_void;
}

/* (mem{move,cpy} dest-ptr [dest-offset] src-ptr [src-offset] count [ctype])
 *   Copies count * sizeof(ctype) bytes
 *   from src-ptr + src-offset * sizeof(ctype)
 *   to dest-ptr + dest-offset * sizeof(ctype).
 * --or--
 * (memset dest-ptr [dest-offset] byte count [ctype])
 *   Sets count * sizeof(ctype) bytes to byte
 *   at dest-ptr + dest-offset * sizeof(ctype) */
static Scheme_Object *do_memop(const char *who, int mode,
                               int argc, Scheme_Object **argv)
/* mode 0=>memset, 1=>memmove, 2=>memcpy */
{
  void *src = NULL, *dest = NULL;
  intptr_t soff = 0, doff = 0, count, v, mult = 0;
  int i, j, ch = 0, argc1 = argc;
  Scheme_Object *cp;

  /* arg parsing: last optional ctype, then count, then fill byte for memset,
   * then the first and second pointer+offset pair. */

  /* get the optional last ctype multiplier */
  if (SCHEME_CTYPEP(argv[argc1-1])) {
    argc1--;
    mult = ctype_sizeof(argv[argc1]);
    if (mult < 0)
      scheme_wrong_contract(who, "ctype?", argc1, argc, argv);
    if (mult <= 0)
      wrong_void(who, NULL, 0, argc1, argc, argv);
  }

  /* get the count argument */
  argc1--;
  if ((!scheme_get_int_val(argv[argc1], &count)) || (count < 0))
    wrong_intptr(who, argc1, argc, argv);
  if (mult) count *= mult;

  /* get the fill byte for memset */
  if (!mode) {
    argc1--;
    ch = SCHEME_INTP(argv[argc1]) ? SCHEME_INT_VAL(argv[argc1]) : -1;
    if ((ch < 0) || (ch > 255))
      scheme_wrong_contract(who, "byte?", argc1, argc, argv);
  }

  /* get the two pointers + offsets */
  i = 0;
  for (j=0; j<2; j++) {
    if (!mode && j==1) break; /* memset needs only a dest argument */
    if (!(i<argc1))
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                       "%s: missing a pointer argument for %s",
                       who, (j == 0 ? "destination" : "source"));
    cp = unwrap_cpointer_property(argv[i]);
    if (!SCHEME_FFIANYPTRP(cp))
      scheme_wrong_contract(who, "cpointer?", i, argc, argv);
    switch (j) {
    case 0: dest = SCHEME_FFIANYPTR_VAL(cp);
            doff = SCHEME_FFIANYPTR_OFFSET(cp);
            break;
    case 1: src  = SCHEME_FFIANYPTR_VAL(cp);
            soff = SCHEME_FFIANYPTR_OFFSET(cp);
            break;
    }
    i++;
    if ((i<argc1) && SCHEME_EXACT_INTEGERP(argv[i])) {
      if (!scheme_get_int_val(argv[i], &v))
        wrong_intptr(who, i, argc, argv);
      if (mult) v *= mult;
      switch (j) {
      case 0: doff += v; break;
      case 1: soff += v; break;
      }
      i++;
    }
  }

  /* verify that there are no unused leftovers */
  if (!(i==argc1))
    scheme_arg_mismatch(who, "unexpected extra argument: ", argv[i]);

  switch (mode) {
  case 0: memset (W_OFFSET(dest, doff), ch, count); break;
  case 1: memmove(W_OFFSET(dest, doff), W_OFFSET(src, soff), count); break;
  case 2: memcpy (W_OFFSET(dest, doff), W_OFFSET(src, soff), count); break;
  }

  return scheme_void;
}

@cdefine[vector->cpointer 1 #:kind immed]{
  if (!SCHEME_VECTORP(argv[0]))
    scheme_wrong_contract(MYNAME, "vector?", 0, argc, argv);
  return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_VEC_ELS((Scheme_Object *)0x0), NULL);
}

@cdefine[flvector->cpointer 1 #:kind immed]{
  if (!SCHEME_FLVECTORP(argv[0]))
    scheme_wrong_contract(MYNAME, "flvector?", 0, argc, argv);
  return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_FLVEC_ELS((Scheme_Object *)0x0), NULL);
}

@cdefine[extflvector->cpointer 1 #:kind immed]{
@@@IFDEF{MZ_LONG_DOUBLE}{
  if (!SCHEME_EXTFLVECTORP(argv[0]))
    scheme_wrong_contract(MYNAME, "extflvector?", 0, argc, argv);
  return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_EXTFLVEC_ELS((Scheme_Object *)0x0), NULL);
 }{
  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
                   MYNAME ": " NOT_SUPPORTED_STR);
  return NULL;
 }
}

@cdefine[memset  3 5]{return do_memop(MYNAME, 0, argc, argv);}
@cdefine[memmove 3 6]{return do_memop(MYNAME, 1, argc, argv);}
@cdefine[memcpy  3 6]{return do_memop(MYNAME, 2, argc, argv);}

@defsymbols[abs]

/* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */
/* n defaults to 0 which is the only value that should be used with ffi_objs */
/* if n is given, an 'abs flag can precede it to make n be a byte offset */
/* rather than some multiple of sizeof(type). */
/* WARNING: there are *NO* checks at all, this is raw C level code. */
@cdefine[ptr-ref 2 4 #:kind inline_noncm]{
  intptr_t size=0; void *ptr; Scheme_Object *base;
  intptr_t delta; int gcsrc=1;
  Scheme_Object *cp, *already_ptr = NULL;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(cp);
  delta = SCHEME_FFIANYPTR_OFFSET(cp);
  if (!is_gcable_pointer(cp))
    gcsrc = 0;
  if ((ptr == NULL) && (delta == 0))
    scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
  if (NULL == (base = get_ctype_base(argv[1])))
    scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
  size = ctype_sizeof(base);

  if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
    if (SCHEME_FFIOBJP(cp)) {
      /* The ffiobj pointer is the function pointer. */
      ptr = cp;
      delta = (intptr_t)&(((ffi_obj_struct*)0x0)->obj);
      /* Helps propagate a function name from `ffi-obj' to `ffi-call': */
      already_ptr = cp;
    }
  }

  if (size < 0) {
    /* should not happen */
    scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
  } else if (size == 0) {
    wrong_void(MYNAME, NULL, 0, 1, argc, argv);
  }

  if (argc > 3) {
    if (!SAME_OBJ(argv[2],abs_sym))
      scheme_wrong_contract(MYNAME, "'abs", 2, argc, argv);
    if (!SCHEME_INTP(argv[3]))
      scheme_wrong_contract(MYNAME, "fixnum?", 3, argc, argv);
    if (SCHEME_INT_VAL(argv[3])) {
      delta = add_check_overflow(MYNAME, delta, SCHEME_INT_VAL(argv[3]));
      already_ptr = NULL;
    }
  } else if (argc > 2) {
    if (!SCHEME_INTP(argv[2]))
      scheme_wrong_contract(MYNAME, "fixnum?", 2, argc, argv);
    if (!size)
      scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
    if (SCHEME_INT_VAL(argv[2])) {
      delta = add_check_overflow(MYNAME, delta, mult_check_overflow(MYNAME, size, SCHEME_INT_VAL(argv[2])));
      already_ptr = NULL;
    }
  }
  return C2SCHEME(already_ptr, argv[1], ptr, delta, 0, gcsrc);
}

Scheme_Object *scheme_foreign_ptr_ref(int argc, Scheme_Object **argv)
{
  return foreign_ptr_ref(argc, argv);
}

/* (ptr-set! cpointer type [['abs] n] value) -> void */
/* n defaults to 0 which is the only value that should be used with ffi_objs */
/* if n is given, an 'abs flag can precede it to make n be a byte offset */
/* rather than some multiple of sizeof(type). */
/* WARNING: there are *NO* checks at all, this is raw C level code. */
@cdefine[ptr-set! 3 5 #:kind inline_noncm]{
  intptr_t size=0; void *ptr;
  intptr_t delta;
  Scheme_Object *val = argv[argc-1], *base;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(cp);
  delta = SCHEME_FFIANYPTR_OFFSET(cp);
  if ((ptr == NULL) && (delta == 0))
    scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
  if (NULL == (base = get_ctype_base(argv[1])))
    scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
  size = ctype_sizeof(base);

  if (size < 0) {
    /* should not happen */
    scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
  } else if (size == 0) {
    wrong_void(MYNAME, NULL, 0, 1, argc, argv);
  }

  if (argc > 4) {
    if (!SAME_OBJ(argv[2],abs_sym))
      scheme_wrong_contract(MYNAME, "'abs", 2, argc, argv);
    if (!SCHEME_INTP(argv[3]))
      scheme_wrong_contract(MYNAME, "fixnum?", 3, argc, argv);
    delta = add_check_overflow(MYNAME, delta, SCHEME_INT_VAL(argv[3]));
  } else if (argc > 3) {
    if (!SCHEME_INTP(argv[2]))
      scheme_wrong_contract(MYNAME, "fixnum?", 2, argc, argv);
    if (!size)
      scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
    delta = add_check_overflow(MYNAME, delta, mult_check_overflow(MYNAME, size, SCHEME_INT_VAL(argv[2])));
  }
  SCHEME2C(MYNAME, argv[1], ptr, delta, val, NULL, NULL, 0);
  return scheme_void;
}

void scheme_foreign_ptr_set(int argc, Scheme_Object **argv)
{
  (void)foreign_ptr_set_bang(argc, argv);
}

/* (ptr-equal? cpointer cpointer) -> boolean */
@cdefine[ptr-equal? 2 2]{
  Scheme_Object *cp1, *cp2;
  cp1 = unwrap_cpointer_property(argv[0]);
  cp2 = unwrap_cpointer_property(argv[1]);
  if (!SCHEME_FFIANYPTRP(cp1))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  if (!SCHEME_FFIANYPTRP(cp2))
    scheme_wrong_contract(MYNAME, "cpointer?", 1, argc, argv);
  return (SAME_OBJ(cp1, cp2) ||
          (SCHEME_FFIANYPTR_OFFSETVAL(cp1)
           == SCHEME_FFIANYPTR_OFFSETVAL(cp2)))
         ? scheme_true : scheme_false;
}

/* (make-sized-byte-string cpointer len) */
@cdefine[make-sized-byte-string 2 2]{
  /* Warning: no copying is done so it is possible to share string contents. */
  /* Warning: if source ptr has a offset, resulting string object uses shifted
   * pointer.
   * (Should use real byte-strings with new version.) */
  intptr_t len;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  if (!scheme_get_int_val(argv[1],&len))
    wrong_intptr(MYNAME, 1, argc, argv);
  return scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(cp),
                                       len, 0);
}

/*****************************************************************************/
/* FFI named locks */

THREAD_LOCAL_DECL(static Scheme_Hash_Table *ffi_lock_ht);

#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
static Scheme_Object *make_vector_in_master(int count, Scheme_Object *val) {
  Scheme_Object *vec;
  void *original_gc;
  original_gc = GC_switch_to_master_gc();
  vec = scheme_make_vector(count, val);
  GC_switch_back_from_master(original_gc);
  return vec;
}

static void **malloc_immobile_box_in_master(Scheme_Object *v)
{
  void **imm;
  void *original_gc;
  original_gc = GC_switch_to_master_gc();
  imm = scheme_malloc_immobile_box(v);
  GC_switch_back_from_master(original_gc);
  return imm;
}
#endif

static void *name_to_ffi_lock(Scheme_Object *bstr)
{
  Scheme_Object *lock;
  
  if (!ffi_lock_ht) {
    REGISTER_SO(ffi_lock_ht);
    ffi_lock_ht = scheme_make_hash_table_equal();
  }
  
  lock = scheme_hash_get(ffi_lock_ht, bstr);
  if (!lock) {
    @@@IFDEF{MZ_USE_PLACES}{
      /* implement the lock with a compare-and-swap with fallback (on
         contention) to a place channel; this strategy has minimal
         overhead when there's no contention, which is good for avoiding
         a penalty in the common case of a single place (but it's probably
         not the best strategy for a contended lock) */
      void *lock_box, *old_lock_box;

      lock_box = scheme_register_process_global(SCHEME_BYTE_STR_VAL(bstr), NULL);
      if (!lock_box) {
        lock = scheme_place_make_async_channel();
        lock = make_vector_in_master(2, lock);
        SCHEME_VEC_ELS(lock)[1] = scheme_make_integer(-1);
        lock_box = malloc_immobile_box_in_master(lock);
        old_lock_box = scheme_register_process_global(SCHEME_BYTE_STR_VAL(bstr), lock_box);
        if (old_lock_box) {
          scheme_free_immobile_box(lock_box);
          lock_box = old_lock_box;
        }
      }
      lock = *(Scheme_Object **)lock_box;
    }{
      lock = scheme_make_sema(1);
    }
    scheme_hash_set(ffi_lock_ht, bstr, lock);
  }
  
  return lock;
}

static void wait_ffi_lock(Scheme_Object *lock)
{
  @@@IFDEF{MZ_USE_PLACES}{
    while (1) {
      if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
                   (uintptr_t)scheme_make_integer(-1),
                   (uintptr_t)scheme_make_integer(scheme_current_place_id))) {
        /* obtained lock the fast way */
        break;
      } else if (!scheme_place_can_receive()) {
        /* We can get here while trying to terminate a place and run
           custodian callbacks or other shutdown actions, and since
           the place is shutting down, we can't commuincate with other
           places; since we can't pause nicely, just spin */
      } else {
        Scheme_Object *owner, *new_val;
        owner = SCHEME_VEC_ELS(lock)[1];
        if (SCHEME_INT_VAL(owner) != -1) {
          if (SCHEME_INT_VAL(owner) < -1) {
            /* other processes waiting, and now there's one more: */
            new_val = scheme_make_integer(SCHEME_INT_VAL(owner)-1);
          } else {
            /* notify owner that another process is now waiting: */
            new_val = scheme_make_integer(-2);
          }
          if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
                       (uintptr_t)owner,
                       (uintptr_t)new_val)) {
            /* wait for lock the slow way - without blocking other Racket threads */
            (void)scheme_place_async_channel_receive(SCHEME_VEC_ELS(lock)[0]);

            /* not waiting anymore: */
            while (1) {
              owner = SCHEME_VEC_ELS(lock)[1];
              if (SCHEME_INT_VAL(owner) == -2) {
                /* no other processes waiting */
                new_val = scheme_make_integer(scheme_current_place_id);
              } else {
                /* one less process waiting */
                new_val = scheme_make_integer(SCHEME_INT_VAL(owner)+1);
              }
              if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
                           (uintptr_t)owner,
                           (uintptr_t)new_val)) {
                break;
              }
            }
            break;
          }
        }
      }
    }
  }{
    scheme_wait_sema(lock, 0);
  }
}

static void release_ffi_lock(void *lock)
{
  @@@IFDEF{MZ_USE_PLACES}{
    if (mzrt_cas((uintptr_t *)&(SCHEME_VEC_ELS(lock)[1]),
                 (uintptr_t)scheme_make_integer(scheme_current_place_id),
                 (uintptr_t)scheme_make_integer(-1))) {
      /* released lock with no other process waiting */
    } else {
      /* assert: SCHEME_VEC_ELS(lock)[1] holds a negative
         number corresponding to the number of waiting processes */
      scheme_place_async_channel_send(SCHEME_VEC_ELS(lock)[0], scheme_false);
    }
  }{
    scheme_post_sema(lock);
  }
}

/*****************************************************************************/

static int extract_varargs_after(const char *who, int argc, Scheme_Object **argv, int argpos, int nargs)
{
  int varargs_after;
  
  if (SCHEME_FALSEP(argv[argpos]))
    varargs_after = -1;
  else if (SCHEME_INTP(argv[argpos])
           && (SCHEME_INT_VAL(argv[argpos]) > 0)) {
    varargs_after = SCHEME_INT_VAL(argv[argpos]);
  } else if (SCHEME_BIGNUMP(argv[argpos])
             && SCHEME_BIGPOS((argv[argpos]))) {
    varargs_after = nargs + 1;
  } else {
    varargs_after = -1;
    scheme_wrong_contract(who, "(or/c exact-positive-integer? #f)", argpos, argc, argv);
  }
  if (varargs_after > nargs)
    scheme_contract_error(who, "varargs-after value is too large",
                          "given value", 1, argv[argpos],
                          "argument count", 1, scheme_make_integer(nargs),
                          NULL);

  return varargs_after;
}

/*****************************************************************************/
/* Calling foreign function objects */

#define MAX_QUICK_ARGS 16

typedef void(*VoidFun)(void);

#ifdef MZ_USE_PLACES

typedef struct FFI_Orig_Place_Call {
  int needs_queue;
  ffi_cif *cif;
  void *c_func;
  intptr_t cfoff;
  int nargs;
  ForeignAny *ivals;
  void **avalues;
  intptr_t *offsets;
  void *p;
  void **signal_handle;
  struct FFI_Orig_Place_Call *next, *prev;
} FFI_Orig_Place_Call;

static mzrt_mutex *orig_place_mutex;
static FFI_Orig_Place_Call *orig_place_calls, *orig_place_calls_tail;
static void *orig_place_signal_handle;

static void check_foreign_work(int check_for_in_original);

static void ffi_call_in_orig_place(ffi_cif *cif, void *c_func, intptr_t cfoff,
                                   int nargs, GC_CAN_IGNORE ForeignAny *ivals, void **avalues,
                                   intptr_t *offsets, void *p)
/* This function can trigger a GC, but it won't escape --- unless
   the called function goes back to Racket and raises an exception,
   and raising an exception in a callback creates all sorts of
   other problems, anyway. No other Racket threads will run in the
   place, so it's ok for the arguments to have stack addresses. */
{
  FFI_Orig_Place_Call *todo;
  void *sh;
  int ready;

  if (cached_orig_place_todo) {
    todo = cached_orig_place_todo;
    cached_orig_place_todo = NULL;
  } else
    todo = (FFI_Orig_Place_Call *)malloc(sizeof(FFI_Orig_Place_Call));
  sh = scheme_get_signal_handle();
  todo->signal_handle = sh;
  todo->needs_queue = 1;

  /* It would be simplest to just block the current place while the
     original place handles the call. Unfortunately, something like a
     master GC might be required between now and when the call is
     handled. So, we have to block in an atomic-like way to minimize
     GCs while we wait, but still wake up on an external signal. */

  GC_check_master_gc_request();
  /* If a GC is needed from here on, a signal will be posted
     to the current place */
  
  while (1) {
    todo->cif = cif;
    todo->c_func = c_func;
    todo->cfoff = cfoff;
    todo->nargs = nargs;
    todo->ivals = ivals;
    todo->avalues = avalues;
    todo->offsets = offsets;
    todo->p = p;

    mzrt_mutex_lock(orig_place_mutex);
    if (todo->needs_queue) {
      todo->next = orig_place_calls;
      todo->prev = NULL;
      if (orig_place_calls) 
        orig_place_calls->prev = todo;
      else 
        orig_place_calls_tail = todo;
      orig_place_calls = todo;
      ready = 0;
    } else {
      ready = !todo->signal_handle;
    }
    mzrt_mutex_unlock(orig_place_mutex);    

    if (!ready) {
      /* Tell original-place thread that there's work: */
      scheme_signal_received_at(orig_place_signal_handle);
      /* Wait for notificiation or a master-GC request: */
      scheme_wait_until_signal_received();
    }
    
    mzrt_mutex_lock(orig_place_mutex);
    if (!todo->signal_handle) {
      /* Done */
      mzrt_mutex_unlock(orig_place_mutex);
      if (!cached_orig_place_todo)
        cached_orig_place_todo = todo;
      else
        free(todo);
      break;
    } else {
      /* Pause to allow actions such as a master GC.... */
      if (todo->needs_queue) {
        /* Remove from queue while we might GC: */
        if (todo->prev)
          todo->prev->next = todo->next;
        else
          orig_place_calls = todo->next;
        if (todo->next)
          todo->next->prev = todo->prev;
        else
          orig_place_calls_tail = todo->prev;
      } else {
        /* The call is being handled, so it's too late
           to remove it from the queue! */
      }
      mzrt_mutex_unlock(orig_place_mutex);

      /* Here's the atomic pause: */
      GC_check_master_gc_request(); 
      scheme_start_atomic();
      scheme_thread_block(0.0);
      scheme_end_atomic_no_swap();

      /* Since we called scheme_thread_block() in atomic mode,
         it doesn't check for foreign callbacks. We'd like
         to handle those anyway, since the call in the original
         place may lead to a callback that should run in
         this place. */
      @@IFNDEF{MZ_USE_FFIPOLL}{
        check_foreign_work(0);
      }
    }
  }
}
#endif

static void finish_ffi_call(ffi_cif *cif, void *c_func, intptr_t cfoff,
                            int nargs, GC_CAN_IGNORE ForeignAny *ivals, void **avalues,
                            intptr_t *offsets, void *p)
/* Complete an FFI call in non-GC mode, so that arguments won't move around: */
  XFORM_SKIP_PROC
{
  int i;
  for (i=0; i<nargs; i++) {
    if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
      avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
    else if ((ivals[i].x_fixnum != FOREIGN_struct)
             && (ivals[i].x_fixnum != FOREIGN_union)) { /* if *not* a struct... */
      /* ... set the ivals pointer (pointer type doesn't matter) and avalues */
      ivals[i].x_pointer = avalues[i];
      avalues[i] = &(ivals[i]);
    } else if (offsets[i]) {
      /* struct argument has an offset */
      avalues[i] = (char *)avalues[i] + offsets[i];
    }
    /* Otherwise it was a struct pointer, and avalues[i] is already fine. */
    /* Add offset, if any: */
    if (offsets[i] != 0) {
      ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i];
    }
  }
  /* Finally, call the function */
  ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues);
}

static void finish_ffi_call_handle_exn(ffi_cif *cif, void *c_func, intptr_t cfoff,
                                       int nargs, GC_CAN_IGNORE ForeignAny *ivals, void **avalues,
                                       intptr_t *offsets, void *p,
                                       Scheme_Object *lock)
{
  mz_jmp_buf * volatile save, fresh;

  save = scheme_current_thread->error_buf;
  scheme_current_thread->error_buf = &fresh;

  if (scheme_setjmp(scheme_error_buf)) {
    if (SCHEME_TRUEP(lock))
      release_ffi_lock(lock);
    scheme_end_in_scheduler();
    scheme_longjmp(*save, 1);
  } else {
    finish_ffi_call(cif, c_func, cfoff,
                    nargs, ivals, avalues, 
                    offsets, p);
  }

  scheme_current_thread->error_buf = save;
}

static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object *self)
/* data := {name, c-function, itypes, otype, cif} */
{
  Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0];
  int curried = !SCHEME_VEC_ELS(data)[1] && !SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]);
  const char    *name = ((Scheme_Primitive_Closure *)self)->p.name;
  void          *c_func = (curried
                           ? (void*)SCHEME_PRIM_CLOSURE_ELS(self)[1]
                           : (void*)(SCHEME_VEC_ELS(data)[1]));
  Scheme_Object *itypes = SCHEME_VEC_ELS(data)[2];
  Scheme_Object *otype  = SCHEME_VEC_ELS(data)[3];
  Scheme_Object *base;
  ffi_cif       *cif    = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]);
  intptr_t      cfoff   = (curried
                           ? SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(self)[2])
                           : SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]));
  int           save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]);
  Scheme_Object *lock = SCHEME_VEC_ELS(data)[7];
  int           callback_exns = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[8]);
#ifdef MZ_USE_PLACES
  int           orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[9]);
#endif
  int           nargs /* = cif->nargs, after checking cif */;
  /* When the foreign function is called, we need an array (ivals) of nargs
   * ForeignAny objects to store the actual C values that are created, and we
   * need another array (avalues) for the pointers to these values (this is
   * what libffi actually uses).  To make things more fun, ForeignAny is
   * problematic for the precise GC, since it is sometimes a pointer and
   * sometime not.  To deal with this, while converting argv objects into
   * ivals, scheme_to_c will save pointer values in avalues, so the GC can,
   * ignore ivals -- just before we reach the actual call, avalues is
   * overwritten, but from that point on it is all C code so there is no
   * problem.  Hopefully.
   * (Things get complicated if the C call can involve GC (usually due to a
   * Racket callback), but then the programmer need to arrange for pointers
   * that cannot move.  Because of all this, the *only* array that should not
   * be ignored by the GC is avalues.)
   */
  ForeignAny *ivals;
  void **avalues, *p, *newp;
  GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS], oval;
  void *stack_avalues[MAX_QUICK_ARGS];
  intptr_t stack_offsets[MAX_QUICK_ARGS];
  int i;
  intptr_t basetype, offset, *offsets;
#ifdef MZ_USE_PLACES
  if (orig_place && (scheme_current_place_id == 0) && !MZ_USE_FFIPOLL_COND)
    orig_place = 0;
#endif
  if (!cif) {
    scheme_signal_error("ffi-call: foreign-function reference was already finalized%s%s",
                        name ? "\n  name: " : "",
                        name ? name : "");
    return NULL;
  }
  nargs =  cif->nargs;
  if ((nargs <= MAX_QUICK_ARGS)) {
    ivals   = stack_ivals;
    avalues = stack_avalues;
    offsets = stack_offsets;
  } else {
    ivals   = scheme_malloc_atomic_allow_interior(nargs * sizeof(ForeignAny));
    avalues = scheme_malloc(nargs * sizeof(void*));
    offsets = scheme_malloc_atomic(nargs * sizeof(intptr_t));
  }
  /* iterate on input values and types */
  for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
    /* convert argv[i] according to current itype */
    offset = 0;
    p = SCHEME2C(name, SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
                 &offset, 0);
    if ((p != NULL) || offset) {
      avalues[i] = p;
      ivals[i].x_fixnum = basetype; /* remember the base type */
    } else {
      avalues[i] = NULL;
    }
    offsets[i] = offset;
  }
  base = get_ctype_base(otype); /* verified below, so cannot be NULL */
  /* If this is a struct return value, then need to malloc in any case, even if
   * the size is smaller than ForeignAny, because this value will be
   * returned. */
  if ((CTYPE_PRIMLABEL(base) == FOREIGN_struct)
      || (CTYPE_PRIMLABEL(base) == FOREIGN_union)) {
    /* need to have p be a pointer that is invisible to the GC */
    p = malloc(CTYPE_PRIMTYPE(base)->size);
    {
      Scheme_Malloc_Proc mf;
      mf = ctype_allocator(base);
      newp = mf(CTYPE_PRIMTYPE(base)->size);
    }
  } else {
    p = &oval;
    newp = NULL;
  }

  if (SCHEME_TRUEP(lock))
    wait_ffi_lock(lock);

#ifdef MZ_USE_PLACES
  if (orig_place)
    ffi_call_in_orig_place(cif, c_func, cfoff,
                           nargs, ivals, avalues,
                           offsets, p);
  else
#endif
    {
      if (callback_exns)
        finish_ffi_call_handle_exn(cif, c_func, cfoff,
                                   nargs, ivals, avalues, 
                                   offsets, p, lock);
      else
        finish_ffi_call(cif, c_func, cfoff,
                        nargs, ivals, avalues, 
                        offsets, p);
    }
  
  if (SCHEME_TRUEP(lock))
    release_ffi_lock(lock);

  /* Use `data' to make sure it's kept alive (as far as the GC is concerned)
     until the foreign call returns: */
  if ((void*)data == (void*)scheme_true)
    scheme_signal_error("dummy test succeeded!?");

  if (save_errno != 0) save_errno_values(save_errno);
  ivals = NULL; /* no need now to hold on to this */
  for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
  avalues = NULL;
  switch (CTYPE_PRIMLABEL(base)) {
  case FOREIGN_struct:
  case FOREIGN_union:
    memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
    free(p);
    p = newp;
    break;
  case FOREIGN_array:
    /* array as result is treated as a pointer, so
       adjust `p' to make C2SCHEME work right */
    p = *(void **)p;
    break;
  }
  return C2SCHEME(NULL, otype, p, 0, 1, 1);
}

static Scheme_Object *ffi_do_call_k()
{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object **argv, *self;

  argv = (Scheme_Object **)p->ku.k.p1;
  self = (Scheme_Object *)p->ku.k.p2;

  p->ku.k.p1 = NULL;
  p->ku.k.p2 = NULL;

  return ffi_do_call(p->ku.k.i1, argv, self);
}

static Scheme_Object *ffi_do_call_after_stack_check(int argc, Scheme_Object *argv[], Scheme_Object *self)
{
  /* Make sure we have an extra-comfortable amount of space on the
     stack before calling into foreign code: */
  if (!scheme_no_stack_overflow && scheme_is_stack_too_shallow()) {
    Scheme_Thread *p = scheme_current_thread;
    p->ku.k.i1 = argc;
    p->ku.k.p1 = argv;
    p->ku.k.p2 = self;
    return scheme_handle_stack_overflow(ffi_do_call_k);
  } else
    return ffi_do_call(argc, argv, self);
}

/* see below */
void free_fficall_data(void *data, void *p)
{
  SCHEME_VEC_ELS(data)[4] = NULL;
  free(((ffi_cif*)p)->arg_types);
  free(p);
}

static Scheme_Object *ffi_name = NULL;

static Scheme_Object *make_ffi_call_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self)
{
  Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0];
  Scheme_Object *a[3], *name, *itypes, *obj, *cp;
  const char *name_str;
  intptr_t ooff;
  int nargs;

  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract("make-ffi-call", "(or/c ffi-obj? cpointer?)", 0, argc, argv);
  obj = SCHEME_FFIANYPTR_VAL(cp);
  ooff = SCHEME_FFIANYPTR_OFFSET(cp);
  if ((obj == NULL) && (ooff == 0))
    scheme_wrong_contract("make-ffi-call", NON_NULL_CPOINTER, 0, argc, argv);

  name = SCHEME_VEC_ELS(data)[0];
  if (SCHEME_FFIOBJP(cp))
    name_str = ((ffi_obj_struct*)(cp))->name;
  else
    name_str = SCHEME_BYTE_STR_VAL(name);

  itypes = SCHEME_VEC_ELS(data)[2];

  nargs = scheme_proper_list_length(itypes);

  a[0] = data;
  a[1] = obj;
  a[2] = scheme_make_integer_value(ooff);

  return scheme_make_prim_closure_w_arity(ffi_do_call_after_stack_check,
                                          3, a, 
                                          name_str,
                                          nargs, nargs);
  
}

static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) {
# define ARGPOS(n) ((n) - (curry ? 1 : 0))
  Scheme_Object *itypes = argv[ARGPOS(1)];
  Scheme_Object *otype  = argv[ARGPOS(2)];
  Scheme_Object *obj, *data, *p, *base, *cp, *name, *a[1];
  ffi_abi abi;
  int varargs_after;
  intptr_t ooff;
  GC_CAN_IGNORE ffi_type *rtype, **atypes;
  GC_CAN_IGNORE ffi_cif *cif;
  int i, nargs, save_errno, callback_exns;
  Scheme_Object *lock = scheme_false;
  Scheme_Performance_State perf_state;
  @@@IFDEF{MZ_USE_PLACES}{
    int orig_place = MZ_USE_FFIPOLL_COND;
    @DEFINE{FFI_CALL_VEC_SIZE 10}
  }{
    @DEFINE{FFI_CALL_VEC_SIZE 9}
  }
  scheme_performance_record_start(&perf_state);
  if (!curry) {
    cp = unwrap_cpointer_property(argv[ARGPOS(0)]);
    if (!SCHEME_FFIANYPTRP(cp))
      scheme_wrong_contract(who, "(or/c ffi-obj? cpointer?)", ARGPOS(0), argc, argv);
    obj = SCHEME_FFIANYPTR_VAL(cp);
    ooff = SCHEME_FFIANYPTR_OFFSET(cp);
    if ((obj == NULL) && (ooff == 0))
      scheme_wrong_contract(who, NON_NULL_CPOINTER, 0, argc, argv);
  } else {
    cp = NULL;
    obj = NULL;
    ooff = 0;
  }
  nargs = scheme_proper_list_length(itypes);
  if (nargs < 0)
    scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv);
  if (NULL == (base = get_ctype_base(otype)))
    scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv);
  rtype = CTYPE_ARG_PRIMTYPE(base);
  abi = GET_ABI(who, ARGPOS(3));
  if (argc > ARGPOS(4)) {
    save_errno = -1;
    if (SCHEME_FALSEP(argv[ARGPOS(4)]))
      save_errno = 0;
    else if (SCHEME_SYMBOLP(argv[ARGPOS(4)])
             && !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) {
      if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix"))
        save_errno = 1;
      else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows"))
        save_errno = 2;
    }
    if (save_errno == -1) {
      scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv);
    }
  } else
    save_errno = 0;
  @@IF{defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL)}{
    if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]);
    else orig_place = 0;
  }
  if (argc > ARGPOS(6)) {
    if (!SCHEME_FALSEP(argv[ARGPOS(6)])) {
      if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(6)]))
        scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(6), argc, argv);
      lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(6)]));
    }
  }
  /* ARGPOS(7) is `blocking?`, but we don't use that */
  if (argc > ARGPOS(8)) {
    varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(8), nargs);
  } else
    varargs_after = -1;
  if (argc > ARGPOS(9))
    callback_exns = SCHEME_TRUEP(argv[ARGPOS(9)]);
  else
    callback_exns = 0;

  if (cp && SCHEME_FFIOBJP(cp))
    name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name);
  else
    name = ffi_name;
  atypes = malloc(nargs * sizeof(ffi_type*));
  for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
    if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
      scheme_wrong_contract(who, "(listof ctype?)", ARGPOS(1), argc, argv);
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
      wrong_void(who, SCHEME_CAR(p), 1, ARGPOS(1), argc, argv);
    atypes[i] = CTYPE_ARG_PRIMTYPE(base);
  }
  cif = malloc(sizeof(ffi_cif));
  if (varargs_after == -1) {
    if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
      scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
  } else {
    if (ffi_prep_cif_var(cif, abi, varargs_after, nargs, rtype, atypes) != FFI_OK)
      scheme_signal_error("internal error: ffi_prep_cif_var did not return FFI_OK");
  }
  data = scheme_make_vector(FFI_CALL_VEC_SIZE, NULL);
  SCHEME_VEC_ELS(data)[0] = name;
  SCHEME_VEC_ELS(data)[1] = obj;
  SCHEME_VEC_ELS(data)[2] = itypes;
  SCHEME_VEC_ELS(data)[3] = otype;
  SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
  SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
  SCHEME_VEC_ELS(data)[6] = scheme_make_integer(save_errno);
  SCHEME_VEC_ELS(data)[7] = lock;
  SCHEME_VEC_ELS(data)[8] = (callback_exns ? scheme_true : scheme_false);
  @@IFDEF{MZ_USE_PLACES}{
    SCHEME_VEC_ELS(data)[9] = (orig_place ? scheme_true : scheme_false);
  }
  scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
  a[0] = data;

  scheme_performance_record_end("comp-ffi-call", &perf_state);

  if (curry) {
    return scheme_make_prim_closure_w_arity(make_ffi_call_from_curried, 
                                            1, a, 
                                            "make-ffi-call",
                                            1, 1);
  } else {
    return scheme_make_prim_closure_w_arity(ffi_do_call_after_stack_check, 
                                            1, a, 
                                            SCHEME_BYTE_STR_VAL(name),
                                            nargs, nargs);
  }
#undef ARGPOS
}

/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place? lock-name blocking? varargs-after exns?]) -> (in-types -> out-value) */
/* the real work is done by ffi_do_call above */
@cdefine[ffi-call 3 10]{
  return ffi_call_or_curry(MYNAME, 0, argc, argv);
}

/* (ffi-call-maker in-types out-type [abi save-errno? orig-place? lock-name blocking? varargs-after exns?]) -> (ffi->obj -> (in-types -> out-value)) */
/* Curried version of `ffi-call` */
@cdefine[ffi-call-maker 2 9]{
  return ffi_call_or_curry(MYNAME, 1, argc, argv);
}

/*****************************************************************************/
/* Racket callbacks */

typedef void (*ffi_callback_t)(ffi_cif* cif, void* resultp, void** args, void *userdata);

static ffi_callback_struct *extract_ffi_callback(void *userdata)
  XFORM_SKIP_PROC
{
  ffi_callback_struct *data;

#ifdef MZ_PRECISE_GC
  {
    void *tmp;
    tmp  = *((void**)userdata);
    data = (ffi_callback_struct *)SCHEME_WEAK_BOX_VAL(tmp);
    if (data == NULL) scheme_signal_error("callback lost");
  }
#else
  data = (ffi_callback_struct *)userdata;
#endif

  return data;
}

static void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
{
  ffi_callback_struct *data;
  Scheme_Object *argv_stack[MAX_QUICK_ARGS];
  int argc = cif->nargs, i;
  Scheme_Object **argv, *p, *v, *t;

  data = extract_ffi_callback(userdata);

  if (argc <= MAX_QUICK_ARGS)
    argv = argv_stack;
  else
    argv = scheme_malloc(argc * sizeof(Scheme_Object*));
  if (data->sync && !SCHEME_PROCP(data->sync))
    scheme_start_in_scheduler();
  for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
    t = SCHEME_CAR(p);
    if (CTYPE_PRIMLABEL(get_ctype_base(t)) == FOREIGN_array) {
      /* array as argument is treated as a pointer */
      v = C2SCHEME(NULL, t, *(void **)(args[i]), 0, 0, 0);
    } else
      v = C2SCHEME(NULL, t, args[i], 0, 0, 0);
    argv[i] = v;
  }
  p = _scheme_apply(data->proc, argc, argv);
  SCHEME2C("callback result", data->otype, resultp, 0, p, NULL, NULL, 1);
  if (data->sync && !SCHEME_PROCP(data->sync))
    scheme_end_in_scheduler();
}

#ifdef MZ_USE_MZRT

/* When OS-level thread support is available, support callbacks
   in foreign threads that are executed on the main Racket thread. */

typedef struct Queued_Callback {
  ffi_cif* cif;
  void* resultp;
  void** args;
  void *userdata;
  mzrt_sema *sema;
  int called;
  struct Queued_Callback *next;
} Queued_Callback;

typedef struct FFI_Sync_Queue {
  Queued_Callback *callbacks; /* malloc()ed list */
  mzrt_mutex *lock;
  mzrt_os_thread_id orig_thread;  
  void *sig_hand;
} FFI_Sync_Queue;

THREAD_LOCAL_DECL(static struct FFI_Sync_Queue *ffi_sync_queue);

static Scheme_Object *callback_thunk(void *_qc, int argc, Scheme_Object *argv[])
{
  Queued_Callback *qc = (Queued_Callback *)_qc;

  if (qc->called)
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "callback thunk for synchronization has already been called");
  qc->called = 1;

  ffi_do_callback(qc->cif, qc->resultp, qc->args, qc->userdata);

  mzrt_sema_post(qc->sema);

  return scheme_void;
}

static void check_foreign_work(int check_for_in_original)
  @@IFDEF{MZ_USE_FFIPOLL}{XFORM_SKIP_PROC}
{
  GC_CAN_IGNORE Queued_Callback *qc;
  ffi_callback_struct *data;
  Scheme_Object *a[1], *proc;

#ifdef MZ_USE_FFIPOLL
  /* We don't currently support callbacks from C to Racket in FFIPOLL
     mode, and this function is not allowed to touch the GC or Racket
     in that mode. */
#else
  if (ffi_sync_queue) {
    do {
      mzrt_mutex_lock(ffi_sync_queue->lock);
      qc = ffi_sync_queue->callbacks;
      if (qc)
        ffi_sync_queue->callbacks = qc->next;
      mzrt_mutex_unlock(ffi_sync_queue->lock);

      if (qc) {
        qc->next = NULL;

        data = extract_ffi_callback(qc->userdata);

        proc = scheme_make_closed_prim_w_arity(callback_thunk, (void *)qc,
                                               "callback-thunk", 0, 0);
        a[0] = proc;

        proc = data->sync;
        if (SCHEME_BOXP(proc)) proc = SCHEME_BOX_VAL(proc);

        scheme_start_in_scheduler();
        _scheme_apply(proc, 1, a);
        scheme_end_in_scheduler();
      }

    } while (qc);
  }
#endif

#ifdef MZ_USE_PLACES
  if (check_for_in_original && ((scheme_current_place_id == 0) || MZ_USE_FFIPOLL_COND) && orig_place_mutex) {
    FFI_Orig_Place_Call *todo;
    void *sh;

    while (1) {
      mzrt_mutex_lock(orig_place_mutex);
      todo = orig_place_calls_tail;
      if (todo) {
        orig_place_calls_tail = todo->prev;
        if (todo->prev)
          todo->prev->next = NULL;
        else
          orig_place_calls = NULL;
        todo->needs_queue = 0;
      }
      mzrt_mutex_unlock(orig_place_mutex);

      if (todo) {
        finish_ffi_call(todo->cif, todo->c_func, todo->cfoff,
                        todo->nargs, todo->ivals, todo->avalues,
                        todo->offsets, todo->p);
        mzrt_mutex_lock(orig_place_mutex);
        sh = todo->signal_handle;
        todo->signal_handle = NULL; /* indicates "done" */
        scheme_signal_received_at(sh);
        mzrt_mutex_unlock(orig_place_mutex);
      } else
        break;
    }
  }
#endif
}

void scheme_check_foreign_work(void)
  @@IFDEF{MZ_USE_FFIPOLL}{XFORM_SKIP_PROC}
{
  check_foreign_work(1);
}

#endif

static void ffi_queue_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
  XFORM_SKIP_PROC
{
#ifdef MZ_USE_MZRT
  /* This function must not refer to any GCable address, not even
     temporarily, because a GC may occur concurrent to this
     function if it's in another thread. */
  FFI_Sync_Queue *queue;
  void **data = (void **)userdata;

  queue = (FFI_Sync_Queue *)(data)[1];
  userdata = (data)[0];

  if (queue->orig_thread != mz_proc_os_thread_self()) {
    if (data[2]) {
      /* constant result */
      memcpy(resultp, data[2], (intptr_t)data[3]);
      return;
    } else {
      /* queue  a callback and wait: */
      Queued_Callback *qc;
      mzrt_sema *sema;

      mzrt_sema_create(&sema, 0);

      qc = (Queued_Callback *)malloc(sizeof(Queued_Callback));
      qc->cif = cif;
      qc->resultp = resultp;
      qc->args = args;
      qc->userdata = userdata;
      qc->sema = sema;
      qc->called = 0;

      mzrt_mutex_lock(queue->lock);
      qc->next = queue->callbacks;
      queue->callbacks = qc;
      mzrt_mutex_unlock(queue->lock);
      scheme_signal_received_at(queue->sig_hand);

      /* wait for the callback to be invoked in the main thread */
      mzrt_sema_wait(sema);

      mzrt_sema_destroy(sema);
      free(qc);
      return;
    }
  }
#endif

  ffi_do_callback(cif, resultp, args, userdata);
}

/* see ffi-callback below */
typedef struct closure_and_cif_struct {
  ffi_closure          closure;
  ffi_cif              cif;
#ifdef MZ_PRECISE_GC
  struct immobile_box *data;
#else
  void                *data;
#endif
} closure_and_cif;

/* free the above */
static void free_cl_cif_args(void *ignored, void *p)
{
  /*
  scheme_warning("Releasing cl+cif+args %V %V (%d)",
                 ignored,
                 (((closure_and_cif*)p)->data),
                 SAME_OBJ(ignored,(((closure_and_cif*)p)->data)));
  */
#ifdef MZ_PRECISE_GC
  GC_free_immobile_box((void**)(((closure_and_cif*)p)->data));
#endif
  scheme_free_code(p);
}

#ifdef MZ_USE_MZRT
static void free_cl_cif_queue_args(void *ignored, void *p)
{
  void *data = ((closure_and_cif*)p)->data, *constant_result;
  void **q = (void **)data;
  data = q[0];
  constant_result = q[2];
  free(q);
  if (constant_result) free(constant_result);
#ifdef MZ_PRECISE_GC
  GC_free_immobile_box((void**)data);
#endif
  scheme_free_code(p);
}
#endif

/* In `curry` mode, just check arguments */
static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) {
# define ARGPOS(n) ((n) - (curry ? 1 : 0))
  ffi_callback_struct *data;
  Scheme_Object *itypes = argv[ARGPOS(1)];
  Scheme_Object *otype = argv[ARGPOS(2)];
  Scheme_Object *sync;
  Scheme_Object *p, *base;
  ffi_abi abi;
  int is_atomic;
  int nargs, i, varargs_after;
  ffi_status ffi_ok;
  /* ffi_closure objects are problematic when used with a moving GC.  The
   * problem is that memory that is GC-visible can move at any time.  The
   * solution is to use an immobile-box, which an immobile pointer (in a simple
   * malloced block), which points to the ffi_callback_struct that contains the
   * relevant Racket call details.  Another minor complexity is that an
   * immobile box serves as a reference for the GC, which means that nothing
   * will ever get collected: and the solution for this is to stick a weak-box
   * in the chain.  Users need to be aware of GC issues, and need to keep a
   * reference to the callback object to avoid releasing the whole thing --
   * when that reference is lost, the ffi_callback_struct will be GCed, and a
   * finalizer will free() the malloced memory.  Everything on the malloced
   * part is allocated in one block, to make it easy to free.  The final layout
   * of the various objects is:
   *
   * <<======malloc======>> : <<===========scheme_malloc===============>>
   *                        :
   *    ffi_closure <------------------------\
   *      |  |              :                |
   *      |  |              :                |
   *      |  \--> immobile ----> weak        |
   *      |         box     :    box         |
   *      |                 :     |          |
   *      |                 :     |          |
   *      |                 :     \--> ffi_callback_struct
   *      |                 :               |  |
   *      V                 :               |  \-----> Racket Closure
   *     cif ---> atypes    :               |
   *                        :               \--------> input/output types
   */
  GC_CAN_IGNORE ffi_type *rtype, **atypes;
  GC_CAN_IGNORE ffi_cif *cif;
  GC_CAN_IGNORE ffi_closure *cl;
  GC_CAN_IGNORE closure_and_cif *cl_cif_args;
  GC_CAN_IGNORE ffi_callback_t do_callback;
  GC_CAN_IGNORE void *callback_data;
  Scheme_Performance_State perf_state;
  @@IFDEF{MZ_USE_MZRT}{
    int keep_queue = 0;
    void *constant_reply = NULL;
    int constant_reply_size = 0;
  }

  if (!curry && !SCHEME_PROCP(argv[ARGPOS(0)]))
    scheme_wrong_contract(who, "procedure?", ARGPOS(0), argc, argv);
  nargs = scheme_proper_list_length(itypes);
  if (nargs < 0)
    scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv);
  if (NULL == (base = get_ctype_base(otype)))
    scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv);
  rtype = CTYPE_ARG_PRIMTYPE(base);
  abi = GET_ABI(who, ARGPOS(3));
  is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)]));
  sync = (is_atomic ? scheme_true : NULL);
  if ((argc > ARGPOS(5))
      && !SCHEME_BOXP(argv[ARGPOS(5)])
      && !scheme_check_proc_arity2(NULL, 1, ARGPOS(5), argc, argv, 1))
    scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(5), argc, argv);
  if (argc > ARGPOS(6))
    varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(6), nargs);
  else
    varargs_after = -1;

  if (curry) {
    /* all checks are done */
    return NULL;
  }

  scheme_performance_record_start(&perf_state);
  
  if (((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]))) {
    @@IFDEF{MZ_USE_MZRT}{
      if (!ffi_sync_queue) {
        mzrt_os_thread_id tid;
        void *sig_hand;

        ffi_sync_queue = (FFI_Sync_Queue *)malloc(sizeof(FFI_Sync_Queue));
        tid = mz_proc_os_thread_self();
        ffi_sync_queue->orig_thread = tid;
        mzrt_mutex_create(&ffi_sync_queue->lock);
        sig_hand = scheme_get_signal_handle();
        ffi_sync_queue->sig_hand = sig_hand;
        ffi_sync_queue->callbacks = NULL;
      }
      if (SCHEME_BOXP(argv[ARGPOS(5)])) {
        /* when called in a foreign thread, return a constant */
        constant_reply_size = ctype_sizeof(otype);
        if (!constant_reply_size && SCHEME_VOIDP(SCHEME_BOX_VAL(argv[ARGPOS(5)]))) {
          /* void result */
          constant_reply = scheme_malloc_atomic(1);
        } else {
          /* non-void result */
          constant_reply = scheme_malloc_atomic(constant_reply_size);
          SCHEME2C(who, otype, constant_reply, 0, SCHEME_BOX_VAL(argv[ARGPOS(5)]), NULL, NULL, 0);
        }
      } else {
        /* when called in a foreign thread, queue a reply back here */
        sync = argv[ARGPOS(5)];
        if (is_atomic) sync = scheme_box(sync);
        constant_reply = NULL;
        constant_reply_size = 0;
      }
      keep_queue = 1;
    }
    do_callback = ffi_queue_callback;
  } else
    do_callback = ffi_do_callback;

  /* malloc space for everything needed, so a single free gets rid of this */
  cl_cif_args = scheme_malloc_code(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*));
  scheme_thread_code_start_write();
  cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */
  cif = &(cl_cif_args->cif);
  atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif));
  for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
    if (NULL == (base = get_ctype_base(SCHEME_CAR(p)))) {
      scheme_thread_code_end_write();
      scheme_wrong_contract(who, "(listof ctype?)", ARGPOS(1), argc, argv);
    }
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void) {
      scheme_thread_code_end_write();
      wrong_void(who, SCHEME_CAR(p), 1, ARGPOS(1), argc, argv);
    }
    atypes[i] = CTYPE_ARG_PRIMTYPE(base);
  }
  if (varargs_after == -1) {
    if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
      scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
  } else {
    if (ffi_prep_cif_var(cif, abi, varargs_after, nargs, rtype, atypes) != FFI_OK)
      scheme_signal_error("internal error: ffi_prep_cif_var did not return FFI_OK");
  }
  scheme_thread_code_end_write();
  @cmake["data" ffi-callback
         "cl_cif_args" "(curry ? NULL : argv[ARGPOS(0)])" "argv[ARGPOS(1)]" "argv[ARGPOS(2)]"
         "sync"]
  @@@IFDEF{MZ_PRECISE_GC}{
  {
    /* put data in immobile, weak box */
    GC_CAN_IGNORE void **tmp;
    tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0, 1));
    callback_data = (struct immobile_box*)tmp;
  }
  }{
  callback_data = (void*)data;
  }
  @@IFDEF{MZ_USE_MZRT}{
    if (keep_queue) {
      /* For ffi_queue_callback(), add a level of indirection in `data' to
         hold the place-specific `ffi_sync_queue'.  Use
         `free_cl_cif_queue_args' to clean up this extra level. */
      GC_CAN_IGNORE void **tmp, *cr;
      if (constant_reply) {
        cr = malloc(constant_reply_size ? constant_reply_size : 1);
        memcpy(cr, constant_reply, constant_reply_size);
        constant_reply = cr;
      }
      tmp = (void **)malloc(sizeof(void*) * 4);
      tmp[0] = callback_data;
      tmp[1] = ffi_sync_queue;
      tmp[2] = constant_reply;
      tmp[3] = (void *)(intptr_t)constant_reply_size;
      callback_data = (void *)tmp;
    }
  }
  scheme_thread_code_start_write();
  cl_cif_args->data = callback_data;
  ffi_ok = ffi_prep_closure_loc(cl, cif, do_callback, (void*)(cl_cif_args->data), cl);
  scheme_thread_code_end_write();
  if (ffi_ok != FFI_OK)
    scheme_signal_error
      ("internal error: ffi_prep_closure did not return FFI_OK");
  @@IFDEF{MZ_USE_MZRT}{
    if (keep_queue)
      scheme_register_finalizer(data, free_cl_cif_queue_args, cl_cif_args,
                                NULL, NULL);
    else
  }
  scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL);

  scheme_performance_record_end("comp-ffi-back", &perf_state);

  return (Scheme_Object*)data;
#undef ARGPOS
}

/* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> ffi-callback */
/* the treatment of in-types and out-types is similar to that in ffi-call */
/* the real work is done by ffi_do_callback above */
@cdefine[ffi-callback 3 6]{
  return ffi_callback_or_curry(MYNAME, 0, argc, argv);
}

static Scheme_Object *make_ffi_callback_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self)
{
  Scheme_Object *vec = SCHEME_PRIM_CLOSURE_ELS(self)[0];
  Scheme_Object *a[7];
  int c = SCHEME_VEC_SIZE(vec), i;

  for (i = 0; i < c; i++) {
    a[i+1] = SCHEME_VEC_ELS(vec)[i];
  }
  a[0] = argv[0];

  return ffi_callback_or_curry("make-ffi-callback", 0, c+1, a);
}

/* (ffi-callback-maker in-types out-type [abi atomic? sync]) -> (proc -> ffi-callback) */
/* Curried version of `ffi-callback`. Check arguments eagerly, but we don't do anything
   otherwise until a function is available. */
@cdefine[ffi-callback-maker 2 6]{
  int i;
  Scheme_Object *vec, *a[1];
  
  (void)ffi_callback_or_curry(MYNAME, 1, argc, argv);

  vec = scheme_make_vector(argc, NULL);
  for (i = 0; i < argc; i++) {
    SCHEME_VEC_ELS(vec)[i] = argv[i];
  }
  a[0] = vec;

  return scheme_make_prim_closure_w_arity(make_ffi_callback_from_curried,
                                          1, a, 
                                          "make-ffi-callback",
                                          1, 1);
}

/*****************************************************************************/

@@IFDEF{WINDOWS_DYNAMIC_LOAD}{
  typedef int *(*get_errno_ptr_t)(void);
  static get_errno_ptr_t get_errno_ptr;
}

static void save_errno_values(int kind)
{
  Scheme_Thread *p = scheme_current_thread;

  if (kind == 2) {
    intptr_t v = 0;
    @@IFDEF{WINDOWS_DYNAMIC_LOAD}{
      v = GetLastError();
    }
    p->saved_errno = v;
    return;
  }

  @@IFDEF{WINDOWS_DYNAMIC_LOAD}{
    /* Depending on how Racket is compiled and linked, `errno` might
       not corresponds to the one from "MSVCRT.dll", which is likely
       to be the one that foreign code uses. Go get that one via
       _errno(), which returns a pointer to the current thread's
       `errno`. */
    if (!get_errno_ptr) {
      HMODULE hm;
      hm = LoadLibrary("msvcrt.dll");
      if (hm) {
        get_errno_ptr = (get_errno_ptr_t)GetProcAddress(hm, "_errno");
      }
    }

    if (get_errno_ptr) {
      GC_CAN_IGNORE int *errno_ptr;
      errno_ptr = get_errno_ptr();
      errno = *errno_ptr;
    }
  }

  p->saved_errno = errno;
}

@cdefine[saved-errno 0 1 #:kind immed]{
  Scheme_Thread *p = scheme_current_thread;
  if (argc == 0) {
    return scheme_make_integer_value(p->saved_errno);
  } else {
    intptr_t v;
    if (!scheme_get_int_val(argv[0], &v)) {
      wrong_intptr(MYNAME, 0, argc, argv);
    }
    p->saved_errno = v;
    return scheme_void;
  }
}

@(define standard-errnos
   ;; Error codes defined by IEEE Std 1003.1, 2013 Edition
   ;; (http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/errno.h.html)
   ;; Linux, Mac, *BSD, MinGW all seem to support most (but not necessarily all)
   ;; of these codes.
   '(E2BIG
     EACCES
     EADDRINUSE
     EADDRNOTAVAIL
     EAFNOSUPPORT
     EAGAIN
     EALREADY
     EBADF
     EBADMSG
     EBUSY
     ECANCELED
     ECHILD
     ECONNABORTED
     ECONNREFUSED
     ECONNRESET
     EDEADLK
     EDESTADDRREQ
     EDOM
     EDQUOT
     EEXIST
     EFAULT
     EFBIG
     EHOSTUNREACH
     EIDRM
     EILSEQ
     EINPROGRESS
     EINTR
     EINVAL
     EIO
     EISCONN
     EISDIR
     ELOOP
     EMFILE
     EMLINK
     EMSGSIZE
     EMULTIHOP
     ENAMETOOLONG
     ENETDOWN
     ENETRESET
     ENETUNREACH
     ENFILE
     ENOBUFS
     ENODATA
     ENODEV
     ENOENT
     ENOEXEC
     ENOLCK
     ENOLINK
     ENOMEM
     ENOMSG
     ENOPROTOOPT
     ENOSPC
     ENOSR
     ENOSTR
     ENOSYS
     ENOTCONN
     ENOTDIR
     ENOTEMPTY
     ENOTRECOVERABLE
     ENOTSOCK
     ENOTSUP
     ENOTTY
     ENXIO
     EOPNOTSUPP
     EOVERFLOW
     EOWNERDEAD
     EPERM
     EPIPE
     EPROTO
     EPROTONOSUPPORT
     EPROTOTYPE
     ERANGE
     EROFS
     ESPIPE
     ESRCH
     ESTALE
     ETIME
     ETIMEDOUT
     ETXTBSY
     EWOULDBLOCK
     EXDEV))

@cdefine[lookup-errno 1 #:kind immed]{
  Scheme_Object *v = argv[0];
  @(let ()
    @list{
      if (!SCHEME_SYMBOLP(v)) {
        scheme_wrong_contract(MYNAME, "symbol?", 0, argc, argv);
        return NULL;
      }
      if (SCHEME_SYM_WEIRDP(v))
        return scheme_false;
      @(add-newlines
        (for/list ([e standard-errnos])
            @@IFDEF{@symbol->string[e]}{
            if (!strcmp("@symbol->string[e]", SCHEME_SYM_VAL(v)))
              return scheme_make_integer(@symbol->string[e]);
            }))
      return scheme_false;
    })
}

/*****************************************************************************/

/* (make-late-will-executor) -> #<will-executor> */
@cdefine[make-late-will-executor 0 #:kind immed]{
  return scheme_make_late_will_executor();
}

/* (make-late-weak-box val) -> #<weak-box> */
@cdefine[make-late-weak-box 1 #:kind immed]{
  return scheme_make_late_weak_box(argv[0]);
}

/* (make-late-weak-hasheq) -> #<hash> */
@cdefine[make-late-weak-hasheq 0 #:kind immed]{
  return (Scheme_Object *)scheme_make_bucket_table(20, SCHEME_hash_late_weak_ptr);
}

/*****************************************************************************/

void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
{
  char *str;
  if (CTYPE_PRIMP(ctype)) {
    scheme_print_bytes(pp, "#<ctype:", 0, 8);
    ctype = CTYPE_BASETYPE(ctype);
    if (SCHEME_SYMBOLP(ctype)) {
      str = SCHEME_SYM_VAL(ctype);
      scheme_print_bytes(pp, str, 0, strlen(str));
    } else {
      scheme_print_bytes(pp, "cstruct", 0, 7);
    }
    scheme_print_bytes(pp, ">", 0, 1);
  } else {
    scheme_print_bytes(pp, "#<ctype>", 0, 8);
  }
}

/*****************************************************************************/
/* Initialization */

/* types need to be initialized before places can spawn
 * types become entries in the GC mark and fixup tables
 * this function should initialize read-only globals that can be 
 * shared without locking */
void scheme_init_foreign_globals()
{
  @(maplines (lambda (x)
              (if (equal? (cadr x) "ctype")
                  @list{}
                  @list{@(cadr x)_tag = scheme_make_type("<@(car x)>")}))
             (reverse (cstructs)))
  @@IFDEF{MZ_PRECISE_GC}{
    @(maplines (lambda (x)
                 @list{GC_register_traversers(@(cadr x)_tag, @(cadr x)_SIZE, @;
                         @(cadr x)_MARK, @(cadr x)_FIXUP, 1, 0)})
                 (reverse (cstructs)))
  }
  scheme_set_type_printer(scheme_ctype_type, ctype_printer);
  @(maplines (lambda (sym)
               @list{MZ_REGISTER_STATIC(@(cadr sym));
                     @(cadr sym) = scheme_intern_symbol("@(car sym)")})
             (reverse (symbols)))

  MZ_REGISTER_STATIC(ffi_name);
  ffi_name = scheme_make_byte_string("ffi:proc");
}

void scheme_init_foreign_places() {
  MZ_REGISTER_STATIC(opened_libs);
  opened_libs = scheme_make_hash_table(SCHEME_hash_string);
#ifdef MZ_USE_PLACES
  if (!orig_place_mutex) {
    mzrt_mutex_create(&orig_place_mutex);
    orig_place_signal_handle = scheme_get_signal_handle();
  }
#endif
}

static Scheme_Object *scheme_make_inline_noncm_prim(Scheme_Prim *prim,
						    const char *name,
						    mzshort mina, mzshort maxa)
{
  Scheme_Object *p;
  int flags = 0;

  p = scheme_make_noncm_prim(prim, name, mina, maxa);

  if ((mina <= 1) && (maxa >= 1))
   flags |= SCHEME_PRIM_IS_UNARY_INLINED;
  if ((mina <= 2) && (maxa >= 2))
   flags |= SCHEME_PRIM_IS_BINARY_INLINED;
  if ((mina <= 0) || (maxa > 2))
   flags |= SCHEME_PRIM_IS_NARY_INLINED;

  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags);

  return p;
}

@(define exported-types '("pointer"
                          "float" "double"
                          "int8" "uint8"
                          "int16" "uint16"
                          "int32" "uint32"
                          "int64" "uint64"))

@(maplines
  (lambda (exported)
   @list{Scheme_Object *scheme_@|exported|_ctype})
 exported-types)

void scheme_init_foreign(Scheme_Startup_Env *env)
{
  ctype_struct *t;
  Scheme_Object *s;
  memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer));
  scheme_switch_prim_instance(env, "#%foreign");
  @(maplines
     (lambda (x)
       (define-values (sname cfun min max kind) (apply values x))
       @list{scheme_addto_prim_instance("@sname",
               scheme_make_@|kind|_prim(@cfun, "@sname", @min, @max), env)})
      (reverse (cfunctions)))
  @(map-types
     ;; no need for these, at least for now:
     ;;   MZ_REGISTER_STATIC(@|cname|_sym);
     ;;   @|cname|_sym = scheme_intern_symbol("@stype");
     @list{s = scheme_intern_symbol("@stype");
           @cmake["t" ctype "s"
                  @list{(Scheme_Object*)(void*)(&ffi_type_@ftype)}
                  @list{(Scheme_Object*)FOREIGN_@cname}]
           @(if (member stype exported-types)
                (append
                  @list{REGISTER_SO(scheme_@|stype|_ctype);
                        scheme_@|stype|_ctype = (Scheme_Object *)t;}
                  '("\n"))
                null)@;
           scheme_addto_prim_instance("_@stype", (Scheme_Object*)t, env)})
  scheme_addto_prim_instance("prop:cpointer", scheme_cpointer_property, env);
  scheme_restore_prim_instance(env);
}

/*****************************************************************************/

#else /* DONT_USE_FOREIGN */

int scheme_is_cpointer(Scheme_Object *cp)
{
  return (SCHEME_FALSEP(cp)
          || SCHEME_CPTRP(x)
          || SCHEME_BYTE_STRINGP(x)
          || (SCHEME_CHAPERONE_STRUCTP(cp)
              && scheme_struct_type_property_ref(scheme_cpointer_property, cp)));
}

static Scheme_Object *unimplemented(int argc, Scheme_Object **argv, Scheme_Object *who)
{
  scheme_signal_error("%s: foreign interface not supported for this platform",
                      ((Scheme_Primitive_Proc *)who)->name);
  return NULL;
}

static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object **argv)
{
  return scheme_make_integer(4);
}

static Scheme_Object *foreign_make_ctype(int argc, Scheme_Object **argv)
{
  return scheme_false;
}

static Scheme_Object *foreign_make_late_will_executor(int argc, Scheme_Object *argv[])
{
  return scheme_make_late_will_executor();
}

@(define (lookup name)
  (if (member (cadr name) '("compiler_sizeof"
                            "make_ctype" 
                            "make_late_will_executor"))
      name
      'unimplemented))

void scheme_init_foreign(Scheme_Env *env)
{
  /* Create a dummy module. */
  scheme_switch_prim_instance(env, "#%foreign");
  @(maplines
     (lambda (x)
       (define-values (sname cfun min max kind) (apply values x))
       @list{scheme_addto_primitive_instance("@sname",
              scheme_make_@|kind|_prim((Scheme_Prim *)@(lookup cfun), "@sname", @min, @max), env)})
      (reverse (cfunctions)))
  @(map-types
     @list{scheme_add_global_constant("_@stype", scheme_false, env)})
  scheme_addto_primitive_instance("prop:cpointer", scheme_cpointer_property, env);
  scheme_restore_prim_instance(env);
}

#endif
